How's this code?

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
{-# 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