1 files changed, 78 insertions, 0 deletions
diff --git a/server/src/Persistence/User.hs b/server/src/Persistence/User.hs
new file mode 100644
index 0000000..12145ac
--- /dev/null
+++ b/server/src/Persistence/User.hs
@@ -0,0 +1,78 @@
+module Persistence.User
+  ( list
+  , get
+  , checkPassword
+  , createSignInToken
+  ) where
+
+import qualified Data.Maybe             as Maybe
+import           Data.Text              (Text)
+import           Database.SQLite.Simple (FromRow (fromRow), NamedParam ((:=)))
+import qualified Database.SQLite.Simple as SQLite
+
+import           Common.Model           (Email (..), Password (..), User (..))
+
+import           Model.HashedPassword   (HashedPassword (..))
+import qualified Model.HashedPassword   as HashedPassword
+import           Model.Query            (Query (Query))
+import qualified Model.UUID             as UUID
+
+newtype Row = Row User
+
+instance FromRow Row where
+  fromRow = Row <$> (User <$>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field)
+
+list :: Query [User]
+list =
+  Query (\conn -> do
+    map (\(Row u) -> u) <$>
+      SQLite.query_ conn "SELECT id, creation, email, name from user ORDER BY creation DESC"
+  )
+
+get :: Text -> Query (Maybe User)
+get token =
+  Query (\conn -> do
+    fmap (\(Row u) -> u) . Maybe.listToMaybe <$>
+      SQLite.queryNamed
+        conn
+        "SELECT id, creation, email, name FROM user WHERE sign_in_token = :sign_in_token LIMIT 1"
+        [ ":sign_in_token" := token ]
+  )
+
+data HashedPasswordRow = HashedPasswordRow HashedPassword
+
+instance FromRow HashedPasswordRow where
+  fromRow = HashedPasswordRow <$> (HashedPassword <$> SQLite.field)
+
+checkPassword :: Email -> Password -> Query Bool
+checkPassword (Email email) password =
+  Query (\conn -> do
+    hashedPassword <- fmap (\(HashedPasswordRow p) -> p) . Maybe.listToMaybe <$>
+      SQLite.queryNamed
+        conn
+        "SELECT password FROM user WHERE email = :email LIMIT 1"
+        [ ":email" := email ]
+    case hashedPassword of
+      Just h ->
+        return (HashedPassword.check password h)
+
+      Nothing ->
+        return False
+  )
+
+createSignInToken :: Email -> Query Text
+createSignInToken (Email email) =
+  Query (\conn -> do
+    token <- UUID.generateUUID
+    SQLite.executeNamed
+      conn
+      "UPDATE user SET sign_in_token = :sign_in_token WHERE email = :email"
+      [ ":sign_in_token" := token
+      , ":email" := email
+      ]
+    return token
+  )