Replace persistent by sqlite-simple

5 files changed, 65 insertions, 87 deletions

diff --git a/src/server/Controller/Category.hs b/src/server/Controller/Category.hs
index 19109a3..3f800da 100644
--- a/src/server/Controller/Category.hs
+++ b/src/server/Controller/Category.hs
@@ -7,43 +7,42 @@ module Controller.Category
   ) where
 
 import Control.Monad.IO.Class (liftIO)
-
-import Data.Text (Text)
 import Network.HTTP.Types.Status (ok200, badRequest400)
 import qualified Data.Text.Lazy as TL
 import Web.Scotty hiding (delete)
 
 import Json (jsonId)
-import Model.Database
+import Model.Category (CategoryId)
 import qualified Model.Category as Category
 import qualified Model.Json.CreateCategory as Json
 import qualified Model.Json.EditCategory as Json
 import qualified Model.Message.Key as Key
 import qualified Model.PaymentCategory as PaymentCategory
+import qualified Model.Query as Query
 import qualified Secure
 
 create :: Json.CreateCategory -> ActionM ()
 create (Json.CreateCategory name color) =
   Secure.loggedAction (\_ ->
-    (liftIO . runDb $ Category.create name color) >>= jsonId
+    (liftIO . Query.run $ Category.create name color) >>= jsonId
   )
 
 edit :: Json.EditCategory -> ActionM ()
 edit (Json.EditCategory categoryId name color) =
   Secure.loggedAction (\_ -> do
-    updated <- liftIO . runDb $ Category.edit categoryId name color
+    updated <- liftIO . Query.run $ Category.edit categoryId name color
     if updated
       then status ok200
       else status badRequest400
   )
 
-delete :: Text -> ActionM ()
+delete :: CategoryId -> ActionM ()
 delete categoryId =
   Secure.loggedAction (\_ -> do
-    deleted <- liftIO . runDb $ do
-      paymentCategories <- PaymentCategory.listByCategory (textToKey categoryId)
+    deleted <- liftIO . Query.run $ do
+      paymentCategories <- PaymentCategory.listByCategory categoryId
       if null paymentCategories
-        then Category.delete (textToKey categoryId)
+        then Category.delete categoryId
         else return False
     if deleted
       then
diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs
index ff3e75d..18394d0 100644
--- a/src/server/Controller/Income.hs
+++ b/src/server/Controller/Income.hs
@@ -6,46 +6,40 @@ module Controller.Income
   , deleteOwn
   ) where
 
-import Web.Scotty
-
-import Network.HTTP.Types.Status (ok200, badRequest400)
-
 import Control.Monad.IO.Class (liftIO)
-
-import Database.Persist
-
-import Data.Text (Text)
+import Network.HTTP.Types.Status (ok200, badRequest400)
 import qualified Data.Text.Lazy as TL
-
-import qualified Secure
+import Web.Scotty
 
 import Json (jsonId)
-
-import Model.Database
+import Model.Income (IncomeId)
 import qualified Model.Income as Income
-import qualified Model.Message.Key as Key
 import qualified Model.Json.CreateIncome as Json
 import qualified Model.Json.EditIncome as Json
+import qualified Model.Message.Key as Key
+import qualified Model.Query as Query
+import qualified Model.User as User
+import qualified Secure
 
 create :: Json.CreateIncome -> ActionM ()
 create (Json.CreateIncome date amount) =
   Secure.loggedAction (\user ->
-    (liftIO . runDb $ Income.create (entityKey user) date amount) >>= jsonId
+    (liftIO . Query.run $ Income.create (User.id user) date amount) >>= jsonId
   )
 
 editOwn :: Json.EditIncome -> ActionM ()
 editOwn (Json.EditIncome incomeId date amount) =
   Secure.loggedAction (\user -> do
-    updated <- liftIO . runDb $ Income.editOwn (entityKey user) incomeId date amount
+    updated <- liftIO . Query.run $ Income.editOwn (User.id user) incomeId date amount
     if updated
       then status ok200
       else status badRequest400
   )
 
-deleteOwn :: Text -> ActionM ()
+deleteOwn :: IncomeId -> ActionM ()
 deleteOwn incomeId =
   Secure.loggedAction (\user -> do
-    deleted <- liftIO . runDb $ Income.deleteOwn user (textToKey incomeId)
+    deleted <- liftIO . Query.run $ Income.deleteOwn user incomeId
     if deleted
       then
         status ok200
diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs
index 96d0a49..9fb2aa0 100644
--- a/src/server/Controller/Index.hs
+++ b/src/server/Controller/Index.hs
@@ -4,28 +4,22 @@ module Controller.Index
   ) where
 
 import Control.Monad.IO.Class (liftIO)
-
-import Web.Scotty hiding (get)
-
-import Network.HTTP.Types.Status (ok200)
-
 import Data.Text (Text)
 import Data.Time.Clock (getCurrentTime, diffUTCTime)
-
-import Database.Persist hiding (Key, get)
+import Network.HTTP.Types.Status (ok200)
+import Web.Scotty hiding (get)
 
 import Conf (Conf(..))
+import Model.Init (getInit)
+import Model.Json.Init (InitResult(..))
+import Model.Message.Key
+import Model.User (User)
 import qualified LoginSession
-import Secure (getUserFromToken)
-
-import Model.Database hiding (Key)
 import qualified Model.Json.Conf as M
-import Model.User (getUser)
-import Model.Message.Key
-import Model.SignIn (getSignIn, signInTokenToUsed)
-import Model.Json.Init (InitResult(..))
-import Model.Init (getInit)
-
+import qualified Model.Query as Query
+import qualified Model.SignIn as SignIn
+import qualified Model.User as User
+import Secure (getUserFromToken)
 import View.Page (page)
 
 get :: Conf -> Maybe Text -> ActionM ()
@@ -37,54 +31,54 @@ get conf mbToken = do
         Left errorKey ->
           return . InitError $ errorKey
         Right user ->
-          liftIO . runDb . fmap InitSuccess . getInit $ user
+          liftIO . Query.run . fmap InitSuccess . getInit $ user
     Nothing -> do
       mbLoggedUser <- getLoggedUser
       case mbLoggedUser of
         Nothing ->
           return InitEmpty
         Just user ->
-          liftIO . runDb . fmap InitSuccess . getInit $ user
+          liftIO . Query.run . fmap InitSuccess . getInit $ user
   html $ page (M.Conf { M.currency = currency conf }) initResult
 
-validateSignIn :: Conf -> Text -> ActionM (Either Key (Entity User))
+validateSignIn :: Conf -> Text -> ActionM (Either Key User)
 validateSignIn conf textToken = do
   mbLoggedUser <- getLoggedUser
   case mbLoggedUser of
     Just loggedUser ->
       return . Right $ loggedUser
     Nothing -> do
-      mbSignIn <- liftIO . runDb $ getSignIn textToken
+      mbSignIn <- liftIO . Query.run $ SignIn.getSignIn textToken
       now <- liftIO getCurrentTime
       case mbSignIn of
         Nothing ->
           return . Left $ SignInInvalid
-        Just signInValue ->
-          if signInIsUsed . entityVal $ signInValue
+        Just signIn ->
+          if SignIn.isUsed signIn
             then
               return . Left $ SignInUsed
             else
-              let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signInValue)
+              let diffTime = now `diffUTCTime` (SignIn.creation signIn)
               in  if diffTime > signInExpiration conf
                     then
                       return . Left $ SignInExpired
                     else do
-                      LoginSession.put conf (signInToken . entityVal $ signInValue)
-                      mbUser <- liftIO . runDb $ do
-                        signInTokenToUsed . entityKey $ signInValue
-                        getUser . signInEmail . entityVal $ signInValue
+                      LoginSession.put conf (SignIn.token signIn)
+                      mbUser <- liftIO . Query.run $ do
+                        SignIn.signInTokenToUsed . SignIn.id $ signIn
+                        User.getUser . SignIn.email $ signIn
                       return $ case mbUser of
                         Nothing -> Left UnauthorizedSignIn
                         Just user -> Right user
 
-getLoggedUser :: ActionM (Maybe (Entity User))
+getLoggedUser :: ActionM (Maybe User)
 getLoggedUser = do
   mbToken <- LoginSession.get
   case mbToken of
     Nothing ->
       return Nothing
     Just token -> do
-      liftIO . runDb . getUserFromToken $ token
+      liftIO . Query.run . getUserFromToken $ token
 
 signOut :: Conf -> ActionM ()
 signOut conf = LoginSession.delete conf >> status ok200
diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs
index 831abbf..d71b451 100644
--- a/src/server/Controller/Payment.hs
+++ b/src/server/Controller/Payment.hs
@@ -8,40 +8,40 @@ module Controller.Payment
   ) where
 
 import Control.Monad.IO.Class (liftIO)
-
-import Data.Text (Text)
-import Database.Persist
 import Network.HTTP.Types.Status (ok200, badRequest400)
 import Web.Scotty
 
 import Json (jsonId)
-import Model.Database
+import Model.Payment (PaymentId)
 import qualified Model.Json.CreatePayment as Json
 import qualified Model.Json.EditPayment as Json
+import qualified Model.Json.Payment as Json
 import qualified Model.Payment as Payment
 import qualified Model.PaymentCategory as PaymentCategory
+import qualified Model.Query as Query
+import qualified Model.User as User
 import qualified Secure
 
 list :: ActionM ()
 list =
   Secure.loggedAction (\_ ->
-    (liftIO $ runDb Payment.list) >>= json
+    (liftIO . Query.run $ map Json.fromPayment <$> Payment.list) >>= json
   )
 
 create :: Json.CreatePayment -> ActionM ()
 create (Json.CreatePayment name cost date category frequency) =
   Secure.loggedAction (\user ->
-    (liftIO . runDb $ do
+    (liftIO . Query.run $ do
       PaymentCategory.save name category
-      Payment.create (entityKey user) name cost date frequency
+      Payment.create (User.id user) name cost date frequency
     ) >>= jsonId
   )
 
 editOwn :: Json.EditPayment -> ActionM ()
 editOwn (Json.EditPayment paymentId name cost date category frequency) =
   Secure.loggedAction (\user -> do
-    updated <- liftIO . runDb $ do
-      edited <- Payment.editOwn (entityKey user) paymentId name cost date frequency
+    updated <- liftIO . Query.run $ do
+      edited <- Payment.editOwn (User.id user) paymentId name cost date frequency
       _ <- if edited
         then PaymentCategory.save name category >> return ()
         else return ()
@@ -51,10 +51,10 @@ editOwn (Json.EditPayment paymentId name cost date category frequency) =
       else status badRequest400
   )
 
-deleteOwn :: Text -> ActionM ()
+deleteOwn :: PaymentId -> ActionM ()
 deleteOwn paymentId =
   Secure.loggedAction (\user -> do
-    deleted <- liftIO . runDb $ Payment.deleteOwn (entityKey user) (textToKey paymentId)
+    deleted <- liftIO . Query.run $ Payment.deleteOwn (User.id user) paymentId
     if deleted
       then status ok200
       else status badRequest400
diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
index 1b8121d..152168c 100644
--- a/src/server/Controller/SignIn.hs
+++ b/src/server/Controller/SignIn.hs
@@ -4,48 +4,39 @@ module Controller.SignIn
   ( signIn
   ) where
 
-import Web.Scotty
-
-import Network.HTTP.Types.Status (ok200, badRequest400)
-
-import Database.Persist hiding (Key)
-
 import Control.Monad.IO.Class (liftIO)
-
 import Data.Text (Text)
+import Network.HTTP.Types.Status (ok200, badRequest400)
 import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Lazy as TL
+import Web.Scotty
 
 import Conf (Conf)
-import qualified Conf
-
-import SendMail
-
-import Text.Email.Validate as Email
-
-import Model.Database
-import Model.User
-import Model.SignIn
 import Model.Message.Key
-
+import qualified Conf
+import qualified Model.Query as Query
+import qualified Model.SignIn as SignIn
+import qualified Model.User as User
+import qualified SendMail
+import qualified Text.Email.Validate as Email
 import qualified View.Mail.SignIn as SignIn
 
 signIn :: Conf -> Text -> ActionM ()
 signIn conf login =
   if Email.isValid (TE.encodeUtf8 login)
     then do
-      maybeUser <- liftIO . runDb $ getUser login
+      maybeUser <- liftIO . Query.run $ User.getUser login
       case maybeUser of
         Just user -> do
-          token <- liftIO . runDb $ createSignInToken login
+          token <- liftIO . Query.run $ SignIn.createSignInToken login
           let url = T.concat [
                       if Conf.https conf then "https://" else "http://",
                       Conf.hostname conf,
                       "?signInToken=",
                       token
                     ]
-          maybeSentMail <- liftIO . sendMail $ SignIn.mail conf (entityVal user) url [login]
+          maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [login]
           case maybeSentMail of
             Right _ ->
               status ok200