Report a paste

Please put a quick comment for the admin.

If it looks like spam, the admin will mark it as spam so that the spam filter picks it up in the future.

If the paste contains something private or offensive, it'll probably just be deleted.

How's this code?

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module WebApp(app, Session(Session)) where
import Control.Monad (join)
import Control.Monad.IO.Class (liftIO)
import Crypto.PasswordStore (makePassword, verifyPassword)
import Data.List (sortOn)
import Control.Monad (void)
import Data.Monoid ((<>))
import Data.Proxy (Proxy(..))
import Data.Text (pack, unpack, replace, Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Text.Lazy (toStrict)
import Data.Time
import Database.PostgreSQL.Simple
import GitHub.Data.Name (mkName)
import GitHub.Data.Definitions (Owner)
import GitHub.Data.Repos (Repo)
import Lucid
import Network.HTTP.Types.Status (status404, status500)
import System.Random.Shuffle
import Text.PrettyPrint.ANSI.Leijen (plain)
import Text.Trifecta (parseString)
import Text.Trifecta.Result (Result(Success, Failure), ErrInfo(_errDoc))
import Web.Spock
import GithubContents (githubFile, GithubFileError(..))
import CardParser (deck, Deck(Deck), Card(Card), Side(Side))

newtype Username = Username Text
type AuthedAction m a = ActionCtxT Username m a

data Session = Session { sessionUsername :: Maybe Username, sessionFlashes :: [Text] }

signinRoute = "signin"
doSigninRoute = "dosignin"
landingRoute = root

app :: SpockM Connection Session () ()
app = do
  get signinRoute (signin =<< getCsrfToken)
  post doSigninRoute (void doSignin)
  prehook requireAuth $ do
    get landingRoute landing
    get (var <//> var <//> var) randomCard

requireAuth :: ActionCtxT () _ Username
requireAuth = do
  session <- readSession
  case sessionUsername session of
    Nothing   -> redirect (renderRoute signinRoute)
    Just user -> pure user

landing :: AuthedAction _ _
landing = text "Landing"

signin :: Text -> ActionT _ _
signin csrfToken = do
  session <- readSession
  let flashes = sessionFlashes session
  writeSession (session {sessionFlashes = []})
  html . toStrict . renderText $ do
    doctypehtml_ $ do
      mapM_ (p_ . toHtml) flashes
      form_ [method_ "POST", action_ (renderRoute doSigninRoute)] $ do
        label_ "Username: "
        input_ [type_ "text", name_ "username"]
        label_ "Password: "
        input_ [type_ "text", name_ "password"]
        input_ [type_ "submit", name_ "action", value_ "Sign In"]
        input_ [type_ "submit", name_ "action", value_ "Create Account"]
        input_ [type_ "hidden", name_ "__csrf_token", value_ csrfToken]

flash :: Text -> ActionT _ _
flash msg = do
  session <- readSession
  writeSession (session {sessionFlashes = msg : sessionFlashes session})

doSignin :: ActionT _ _
doSignin = do
  (action :: Maybe Text) <- param "action"
  case action of
    Just "Sign In"        -> signin'
    Just "Create Account" -> createAccount
    _                     -> signinError "action required"

createAccount :: ActionT _ _
createAccount = do
  time <- liftIO getCurrentTime
  (u :: Maybe Text) <- param "username"
  (p :: Maybe Text) <- param "password"
  case (u, p) of
    (Just username, Just password) -> do
      createdNewAccount <- runQuery $ \conn -> do
        [Only exists] <- query conn "select exists (select * from account where username = ?)" (Only username)
        case exists of
          True -> pure False
          False -> do
            hashedPassword <- makePassword (encodeUtf8 password) 20
            _ <- execute conn
              "insert into account (username, password, last_signin) values (?,?,?)"
              (username, hashedPassword, time)
            pure True
      case createdNewAccount of
        True  -> do
          writeSession (Session (Just $ Username username) [])
          redirect (renderRoute landingRoute)
        False -> do
          flash "username already taken"
          redirect (renderRoute signinRoute)
    (_, _) -> signinError "username and password required"

signin' :: ActionT _ _
signin' = do
  (u :: Maybe Text) <- param "username"
  (p :: Maybe Text) <- param "password"
  case (u, p) of
    (Just username, Just password) -> do
      hashedPassword <- runQuery $ \c -> query c "select password from account where username = ?" (Only username)
      case hashedPassword of
        [Only hp] | verifyPassword (encodeUtf8 password) hp -> do writeSession (Session (Just $ Username username) [])
                                                                  redirect (renderRoute landingRoute)
                  | otherwise                               -> signinError "bad credentials"
        _ -> signinError "bad credentials"
    (_, _) -> signinError "username and password required"

signinError :: Text -> ActionT _ _
signinError msg = flash msg >> redirect (renderRoute signinRoute)

randomCard :: Text -> Text -> Text -> AuthedAction _ _
randomCard owner repo path = do
  contents <- liftIO $ githubFile (mkName (Proxy :: Proxy Owner) owner) (mkName (Proxy :: Proxy Repo) repo) path
  case contents of
    Left NotFound  -> setStatus status404 >> text "Could not find file"
    Left Directory -> setStatus status404 >> text "Path refers to a directory"
    Left (Other e) -> setStatus status500 >> text ("Error" <> pack e)
    Right t        -> do
      case parseString deck mempty (unpack t) of
        Failure e -> text . (replace "(interactive):" "") . pack . show . plain . _errDoc $ e
        Success a -> text . pack . show =<< liftIO (shuffleDeck a)

shuffleDeck :: Deck -> IO Deck
shuffleDeck (Deck a) = join $ fmap Deck . sequence . fmap shuffleSortCard <$> shuffleM a

shuffleSortCard :: Card -> IO Card
shuffleSortCard (Card a) = Card . sortOn (\(Side n _) -> n) <$> shuffleM a