12 files changed, 847 insertions, 0 deletions
diff --git a/server/src/Model/Category.hs b/server/src/Model/Category.hs
new file mode 100644
index 0000000..6b7a488
--- /dev/null
+++ b/server/src/Model/Category.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE OverloadedStrings    #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.Category
+  ( list
+  , create
+  , edit
+  , delete
+  ) where
+
+import Data.Maybe (isJust, listToMaybe)
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime)
+import Database.SQLite.Simple (Only(Only), FromRow(fromRow))
+import qualified Database.SQLite.Simple as SQLite
+import Prelude hiding (id)
+
+import Common.Model (Category(..), CategoryId)
+
+import Model.Query (Query(Query))
+
+instance FromRow Category where
+  fromRow = Category <$>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field
+
+list :: Query [Category]
+list =
+  Query (\conn ->
+    SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL"
+  )
+
+create :: Text -> Text -> Query CategoryId
+create categoryName categoryColor =
+  Query (\conn -> do
+    now <- getCurrentTime
+    SQLite.execute
+      conn
+      "INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)"
+      (categoryName, categoryColor, now)
+    SQLite.lastInsertRowId conn
+  )
+
+edit :: CategoryId -> Text -> Text -> Query Bool
+edit categoryId categoryName categoryColor =
+  Query (\conn -> do
+    mbCategory <- listToMaybe <$>
+      (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category])
+    if isJust mbCategory
+      then do
+        now <- getCurrentTime
+        SQLite.execute
+          conn
+          "UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?"
+          (now, categoryName, categoryColor, categoryId)
+        return True
+      else
+        return False
+  )
+
+delete :: CategoryId -> Query Bool
+delete categoryId =
+  Query (\conn -> do
+    mbCategory <- listToMaybe <$>
+      (SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId) :: IO [Category])
+    if isJust mbCategory
+      then do
+        now <- getCurrentTime
+        SQLite.execute
+          conn
+          "UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId)
+        return True
+      else
+        return False
+  )
diff --git a/server/src/Model/Frequency.hs b/server/src/Model/Frequency.hs
new file mode 100644
index 0000000..b334a40
--- /dev/null
+++ b/server/src/Model/Frequency.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE DeriveGeneric        #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE TemplateHaskell      #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.Frequency () where
+
+import Database.SQLite.Simple (SQLData(SQLText))
+import Database.SQLite.Simple.FromField (fieldData, FromField(fromField))
+import Database.SQLite.Simple.Ok (Ok(Ok, Errors))
+import Database.SQLite.Simple.ToField (ToField(toField))
+import qualified Data.Text as T
+
+import Common.Model (Frequency)
+
+instance FromField Frequency where
+  fromField field = case fieldData field of
+    SQLText text -> Ok (read (T.unpack text) :: Frequency)
+    _ -> Errors [error "SQLText field required for frequency"]
+
+instance ToField Frequency where
+  toField frequency = SQLText . T.pack . show $ frequency
diff --git a/server/src/Model/Income.hs b/server/src/Model/Income.hs
new file mode 100644
index 0000000..bbe7657
--- /dev/null
+++ b/server/src/Model/Income.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.Income
+  ( list
+  , create
+  , editOwn
+  , deleteOwn
+  , modifiedDuring
+  ) where
+
+import Data.Maybe (listToMaybe)
+import Data.Time.Calendar (Day)
+import Data.Time.Clock (UTCTime, getCurrentTime)
+import Database.SQLite.Simple (Only(Only), FromRow(fromRow))
+import Prelude hiding (id)
+import qualified Database.SQLite.Simple as SQLite
+
+import Common.Model (Income(..), IncomeId, User(..), UserId)
+
+import Model.Query (Query(Query))
+import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt)
+
+instance Resource Income where
+  resourceCreatedAt = _income_createdAt
+  resourceEditedAt = _income_editedAt
+  resourceDeletedAt = _income_deletedAt
+
+instance FromRow Income where
+  fromRow = Income <$>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field
+
+list :: Query [Income]
+list = Query (\conn -> SQLite.query_ conn "SELECT * FROM income WHERE deleted_at IS NULL")
+
+create :: UserId -> Day -> Int -> Query IncomeId
+create incomeUserId incomeDate incomeAmount =
+  Query (\conn -> do
+    now <- getCurrentTime
+    SQLite.execute
+      conn
+      "INSERT INTO income (user_id, date, amount, created_at) VALUES (?, ?, ?, ?)"
+      (incomeUserId, incomeDate, incomeAmount, now)
+    SQLite.lastInsertRowId conn
+  )
+
+editOwn :: UserId -> IncomeId -> Day -> Int -> Query Bool
+editOwn incomeUserId incomeId incomeDate incomeAmount =
+  Query (\conn -> do
+    mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId)
+    case mbIncome of
+      Just income ->
+        if _income_userId income == incomeUserId
+          then do
+            now <- getCurrentTime
+            SQLite.execute
+              conn
+              "UPDATE income SET edited_at = ?, date = ?, amount = ? WHERE id = ?"
+              (now, incomeDate, incomeAmount, incomeId)
+            return True
+          else
+            return False
+      Nothing ->
+        return False
+  )
+
+deleteOwn :: User -> IncomeId -> Query Bool
+deleteOwn user incomeId =
+  Query (\conn -> do
+    mbIncome <- listToMaybe <$> SQLite.query conn "SELECT * FROM income WHERE id = ?" (Only incomeId)
+    case mbIncome of
+      Just income ->
+        if _income_userId income == _user_id user
+          then do
+            now <- getCurrentTime
+            SQLite.execute conn "UPDATE income SET deleted_at = ? WHERE id = ?" (now, incomeId)
+            return True
+          else
+            return False
+      Nothing ->
+        return False
+  )
+
+modifiedDuring :: UTCTime -> UTCTime -> Query [Income]
+modifiedDuring start end =
+  Query (\conn ->
+    SQLite.query
+      conn
+      "SELECT * FROM income WHERE (created_at >= ? AND created_at <= ?) OR (edited_at >= ? AND edited_at <= ?) OR (deleted_at >= ? AND deleted_at <= ?)"
+      (start, end, start, end, start, end)
+  )
diff --git a/server/src/Model/Init.hs b/server/src/Model/Init.hs
new file mode 100644
index 0000000..8c6a961
--- /dev/null
+++ b/server/src/Model/Init.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Model.Init
+  ( getInit
+  ) where
+
+import Common.Model (Init(Init), User(..))
+
+import Conf (Conf)
+import qualified Conf
+import Model.Query (Query)
+import qualified Model.Category as Category
+import qualified Model.Income as Income
+import qualified Model.Payment as Payment
+import qualified Model.PaymentCategory as PaymentCategory
+import qualified Model.User as User
+
+getInit :: User -> Conf -> Query Init
+getInit user conf =
+  Init <$>
+    User.list <*>
+    (return . _user_id $ user) <*>
+    Payment.list <*>
+    Income.list <*>
+    Category.list <*>
+    PaymentCategory.list <*>
+    (return . Conf.currency $ conf)
diff --git a/server/src/Model/Mail.hs b/server/src/Model/Mail.hs
new file mode 100644
index 0000000..9a4db73
--- /dev/null
+++ b/server/src/Model/Mail.hs
@@ -0,0 +1,12 @@
+module Model.Mail
+  ( Mail(..)
+  ) where
+
+import Data.Text (Text)
+
+data Mail = Mail
+  { from :: Text
+  , to :: [Text]
+  , subject :: Text
+  , plainBody :: Text
+  } deriving (Eq, Show)
diff --git a/server/src/Model/Payer.hs b/server/src/Model/Payer.hs
new file mode 100644
index 0000000..de4abd1
--- /dev/null
+++ b/server/src/Model/Payer.hs
@@ -0,0 +1,216 @@
+module Model.Payer
+  ( getOrderedExceedingPayers
+  ) where
+
+import Data.Map (Map)
+import Data.Time (UTCTime(..), NominalDiffTime)
+import qualified Data.List as List
+import qualified Data.Map as Map
+import qualified Data.Maybe as Maybe
+import qualified Data.Time as Time
+
+import Common.Model (User(..), UserId, Income(..), IncomeId, Payment(..))
+
+type Users = Map UserId User
+
+type Payers = Map UserId Payer
+
+type Incomes = Map IncomeId Income
+
+type Payments = [Payment]
+
+data Payer = Payer
+  { preIncomePaymentSum :: Int
+  , postIncomePaymentSum :: Int
+  , _incomes :: [Income]
+  }
+
+data PostPaymentPayer = PostPaymentPayer
+  { _preIncomePaymentSum :: Int
+  , _cumulativeIncome :: Int
+  , ratio :: Float
+  }
+
+data ExceedingPayer = ExceedingPayer
+  { _userId :: UserId
+  , amount :: Int
+  } deriving (Show)
+
+getOrderedExceedingPayers :: UTCTime -> [User] -> [Income] -> Payments -> [ExceedingPayer]
+getOrderedExceedingPayers currentTime users incomes payments =
+  let usersMap = Map.fromList . map (\user -> (_user_id user, user)) $ users
+      incomesMap = Map.fromList . map (\income -> (_income_id income, income)) $ incomes
+      payers = getPayers currentTime usersMap incomesMap payments
+      exceedingPayersOnPreIncome =
+        exceedingPayersFromAmounts
+          . Map.toList
+          . Map.map preIncomePaymentSum
+          $ payers
+      mbSince = useIncomesFrom usersMap incomesMap payments
+  in  case mbSince of
+        Just since ->
+          let postPaymentPayers = Map.map (getPostPaymentPayer currentTime since) payers
+              mbMaxRatio =
+                safeMaximum
+                  . map (ratio . snd)
+                  . Map.toList
+                  $ postPaymentPayers
+          in  case mbMaxRatio of
+                Just maxRatio ->
+                  exceedingPayersFromAmounts
+                    . Map.toList
+                    . Map.map (getFinalDiff maxRatio)
+                    $ postPaymentPayers
+                Nothing ->
+                  exceedingPayersOnPreIncome
+        _ ->
+          exceedingPayersOnPreIncome
+
+useIncomesFrom :: Users -> Incomes -> Payments -> Maybe UTCTime
+useIncomesFrom users incomes payments =
+  let firstPaymentTime = safeHead . List.sort . map paymentTime $ payments
+      mbIncomeTime = incomeDefinedForAll (Map.keys users) incomes
+  in  case (firstPaymentTime, mbIncomeTime) of
+        (Just t1, Just t2) -> Just (max t1 t2)
+        _ -> Nothing
+
+paymentTime :: Payment -> UTCTime
+paymentTime = flip UTCTime (Time.secondsToDiffTime 0) . _payment_date
+
+getPayers :: UTCTime -> Users -> Incomes -> Payments -> Payers
+getPayers currentTime users incomes payments =
+  let userIds = Map.keys users
+      incomesDefined = incomeDefinedForAll userIds incomes
+  in  Map.fromList
+        . map (\userId ->
+            ( userId
+            , Payer
+                { preIncomePaymentSum =
+                    totalPayments
+                      (\p -> paymentTime p < (Maybe.fromMaybe currentTime incomesDefined))
+                      userId
+                      payments
+                , postIncomePaymentSum =
+                    totalPayments
+                      (\p ->
+                        case incomesDefined of
+                          Nothing -> False
+                          Just t -> paymentTime p >= t
+                      )
+                      userId
+                      payments
+                , _incomes = filter ((==) userId . _income_userId) (Map.elems incomes)
+                }
+            )
+        )
+        $ userIds
+
+exceedingPayersFromAmounts :: [(UserId, Int)] -> [ExceedingPayer]
+exceedingPayersFromAmounts userAmounts =
+  case mbMinAmount of
+    Nothing ->
+      []
+    Just minAmount ->
+      filter (\payer -> amount payer > 0)
+        . map (\userAmount ->
+           ExceedingPayer
+             { _userId = fst userAmount
+             , amount = snd userAmount - minAmount
+             }
+        )
+        $ userAmounts
+  where mbMinAmount = safeMinimum . map snd $ userAmounts
+
+getPostPaymentPayer :: UTCTime -> UTCTime -> Payer -> PostPaymentPayer
+getPostPaymentPayer currentTime since payer =
+  PostPaymentPayer
+    { _preIncomePaymentSum = preIncomePaymentSum payer
+    , _cumulativeIncome = cumulativeIncome
+    , ratio = (fromIntegral . postIncomePaymentSum $ payer) / (fromIntegral cumulativeIncome)
+    }
+  where cumulativeIncome = cumulativeIncomesSince currentTime since (_incomes payer)
+
+getFinalDiff :: Float -> PostPaymentPayer -> Int
+getFinalDiff maxRatio payer =
+  let postIncomeDiff =
+        truncate $ -1.0 * (maxRatio - ratio payer) * (fromIntegral . _cumulativeIncome $ payer)
+  in  postIncomeDiff + _preIncomePaymentSum payer
+
+incomeDefinedForAll :: [UserId] -> Incomes -> Maybe UTCTime
+incomeDefinedForAll userIds incomes =
+  let userIncomes = map (\userId -> filter ((==) userId . _income_userId) . Map.elems $ incomes) userIds
+      firstIncomes = map (safeHead . List.sortOn incomeTime) userIncomes
+  in  if all Maybe.isJust firstIncomes
+        then safeHead . reverse . List.sort . map incomeTime . Maybe.catMaybes $ firstIncomes
+        else Nothing
+
+cumulativeIncomesSince :: UTCTime -> UTCTime -> [Income] -> Int
+cumulativeIncomesSince currentTime since incomes =
+  getCumulativeIncome currentTime (getOrderedIncomesSince since incomes)
+
+getOrderedIncomesSince :: UTCTime -> [Income] -> [Income]
+getOrderedIncomesSince time incomes =
+  let mbStarterIncome = getIncomeAt time incomes
+      orderedIncomesSince = filter (\income -> incomeTime income >= time) incomes
+  in  (Maybe.maybeToList mbStarterIncome) ++ orderedIncomesSince
+
+getIncomeAt :: UTCTime -> [Income] -> Maybe Income
+getIncomeAt time incomes =
+  case incomes of
+    [x] ->
+      if incomeTime x < time
+        then Just $ x { _income_date = utctDay time }
+        else Nothing
+    x1 : x2 : xs ->
+      if incomeTime x1 < time && incomeTime x2 >= time
+        then Just $ x1 { _income_date = utctDay time }
+        else getIncomeAt time (x2 : xs)
+    [] ->
+      Nothing
+
+getCumulativeIncome :: UTCTime -> [Income] -> Int
+getCumulativeIncome currentTime incomes =
+  sum
+    . map durationIncome
+    . getIncomesWithDuration currentTime
+    . List.sortOn incomeTime
+    $ incomes
+
+getIncomesWithDuration :: UTCTime -> [Income] -> [(NominalDiffTime, Int)]
+getIncomesWithDuration currentTime incomes =
+  case incomes of
+    [] ->
+      []
+    [income] ->
+      [(Time.diffUTCTime currentTime (incomeTime income), _income_amount income)]
+    (income1 : income2 : xs) ->
+      (Time.diffUTCTime (incomeTime income2) (incomeTime income1), _income_amount income1) : (getIncomesWithDuration currentTime (income2 : xs))
+
+incomeTime :: Income -> UTCTime
+incomeTime = flip UTCTime (Time.secondsToDiffTime 0) . _income_date
+
+durationIncome :: (NominalDiffTime, Int) -> Int
+durationIncome (duration, income) =
+  truncate $ duration * fromIntegral income / (nominalDay * 365 / 12)
+
+nominalDay :: NominalDiffTime
+nominalDay = 86400
+
+safeHead :: [a] -> Maybe a
+safeHead [] = Nothing
+safeHead (x : _) = Just x
+
+safeMinimum :: (Ord a) => [a] -> Maybe a
+safeMinimum [] = Nothing
+safeMinimum xs = Just . minimum $ xs
+
+safeMaximum :: (Ord a) => [a] -> Maybe a
+safeMaximum [] = Nothing
+safeMaximum xs = Just . maximum $ xs
+
+totalPayments :: (Payment -> Bool) -> UserId -> Payments -> Int
+totalPayments paymentFilter userId payments =
+  sum
+    . map _payment_cost
+    . filter (\payment -> paymentFilter payment && _payment_user payment == userId)
+    $ payments
diff --git a/server/src/Model/Payment.hs b/server/src/Model/Payment.hs
new file mode 100644
index 0000000..14efe77
--- /dev/null
+++ b/server/src/Model/Payment.hs
@@ -0,0 +1,175 @@
+{-# LANGUAGE OverloadedStrings    #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.Payment
+  ( Payment(..)
+  , find
+  , list
+  , listMonthly
+  , create
+  , createMany
+  , editOwn
+  , deleteOwn
+  , modifiedDuring
+  ) where
+
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time (UTCTime)
+import Data.Time.Calendar (Day)
+import Data.Time.Clock (getCurrentTime)
+import Database.SQLite.Simple (Only(Only), FromRow(fromRow), ToRow)
+import Database.SQLite.Simple.ToField (ToField(toField))
+import Prelude hiding (id)
+import qualified Database.SQLite.Simple as SQLite
+
+import Common.Model (Frequency(..), Payment(..), PaymentId, UserId)
+
+import Model.Frequency ()
+import Model.Query (Query(Query))
+import Resource (Resource, resourceCreatedAt, resourceEditedAt, resourceDeletedAt)
+
+instance Resource Payment where
+  resourceCreatedAt = _payment_createdAt
+  resourceEditedAt = _payment_editedAt
+  resourceDeletedAt = _payment_deletedAt
+
+instance FromRow Payment where
+  fromRow = Payment <$>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field
+
+instance ToRow Payment where
+  toRow p =
+    [ toField (_payment_user p)
+    , toField (_payment_name p)
+    , toField (_payment_cost p)
+    , toField (_payment_date p)
+    , toField (_payment_frequency p)
+    , toField (_payment_createdAt p)
+    ]
+
+find :: PaymentId -> Query (Maybe Payment)
+find paymentId =
+  Query (\conn -> listToMaybe <$>
+    SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
+  )
+
+list :: Query [Payment]
+list =
+  Query (\conn ->
+    SQLite.query_ conn "SELECT * FROM payment WHERE deleted_at IS NULL"
+  )
+
+listMonthly :: Query [Payment]
+listMonthly =
+  Query (\conn ->
+    SQLite.query
+      conn
+      (SQLite.Query $ T.intercalate " "
+        [ "SELECT *"
+        , "FROM payment"
+        , "WHERE deleted_at IS NULL AND frequency = ?"
+        , "ORDER BY name DESC"
+        ])
+      (Only Monthly)
+  )
+
+create :: UserId -> Text -> Int -> Day -> Frequency -> Query PaymentId
+create userId paymentName paymentCost paymentDate paymentFrequency =
+  Query (\conn -> do
+    now <- getCurrentTime
+    SQLite.execute
+      conn
+      (SQLite.Query $ T.intercalate " "
+        [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)"
+        , "VALUES (?, ?, ?, ?, ?, ?)"
+        ])
+      (userId, paymentName, paymentCost, paymentDate, paymentFrequency, now)
+    SQLite.lastInsertRowId conn
+  )
+
+createMany :: [Payment] -> Query ()
+createMany payments =
+  Query (\conn ->
+    SQLite.executeMany
+      conn
+      (SQLite.Query $ T.intercalate ""
+        [ "INSERT INTO payment (user_id, name, cost, date, frequency, created_at)"
+        , "VALUES (?, ?, ?, ?, ?, ?)"
+        ])
+      payments
+  )
+
+editOwn :: UserId -> PaymentId -> Text -> Int -> Day -> Frequency -> Query Bool
+editOwn userId paymentId paymentName paymentCost paymentDate paymentFrequency =
+  Query (\conn -> do
+    mbPayment <- listToMaybe <$>
+      SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
+    case mbPayment of
+      Just payment ->
+        if _payment_user payment == userId
+          then do
+            now <- getCurrentTime
+            SQLite.execute
+              conn
+              (SQLite.Query $ T.intercalate " "
+                [ "UPDATE payment"
+                , "SET edited_at = ?,"
+                , "    name = ?,"
+                , "    cost = ?,"
+                , "    date = ?,"
+                , "    frequency = ?"
+                , "WHERE id = ?"
+                ])
+              (now, paymentName, paymentCost, paymentDate, paymentFrequency, paymentId)
+            return True
+          else
+            return False
+      Nothing ->
+        return False
+  )
+
+deleteOwn :: UserId -> PaymentId -> Query Bool
+deleteOwn userId paymentId =
+  Query (\conn -> do
+    mbPayment <- listToMaybe <$>
+      SQLite.query conn "SELECT * FROM payment WHERE id = ?" (Only paymentId)
+    case mbPayment of
+      Just payment ->
+        if _payment_user payment == userId
+          then do
+            now <- getCurrentTime
+            SQLite.execute
+              conn
+              "UPDATE payment SET deleted_at = ? WHERE id = ?"
+              (now, paymentId)
+            return True
+          else
+            return False
+      Nothing ->
+        return False
+  )
+
+modifiedDuring :: UTCTime -> UTCTime -> Query [Payment]
+modifiedDuring start end =
+  Query (\conn ->
+    SQLite.query
+      conn
+      (SQLite.Query $ T.intercalate " "
+        [ "SELECT *"
+        , "FROM payment"
+        , "WHERE (created_at >= ? AND created_at <= ?)"
+        , "   OR (edited_at >= ?  AND edited_at <= ?)"
+        , "   OR (deleted_at >= ? AND deleted_at <= ?)"
+        ])
+      (start, end, start, end, start, end)
+  )
diff --git a/server/src/Model/PaymentCategory.hs b/server/src/Model/PaymentCategory.hs
new file mode 100644
index 0000000..6e1d304
--- /dev/null
+++ b/server/src/Model/PaymentCategory.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE OverloadedStrings    #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.PaymentCategory
+  ( list
+  , listByCategory
+  , save
+  ) where
+
+import Data.Maybe (isJust, listToMaybe)
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime)
+import Database.SQLite.Simple (Only(Only), FromRow(fromRow))
+import qualified Data.Text as T
+import qualified Database.SQLite.Simple as SQLite
+
+import Common.Model (CategoryId, PaymentCategory(..))
+import qualified Common.Util.Text as T
+
+import Model.Query (Query(Query))
+
+instance FromRow PaymentCategory where
+  fromRow = PaymentCategory <$>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field
+
+list :: Query [PaymentCategory]
+list = Query (\conn -> SQLite.query_ conn "SELECT * from payment_category")
+
+listByCategory :: CategoryId -> Query [PaymentCategory]
+listByCategory cat =
+  Query (\conn ->
+    SQLite.query conn "SELECT * FROM payment_category WHERE category = ?" (Only cat)
+  )
+
+save :: Text -> CategoryId -> Query ()
+save newName categoryId =
+  Query (\conn -> do
+    now <- getCurrentTime
+    mbPaymentCategory <- listToMaybe <$>
+      (SQLite.query
+        conn
+        "SELECT * FROM payment_category WHERE name = ?"
+        (Only (formatPaymentName newName)) :: IO [PaymentCategory])
+    if isJust mbPaymentCategory
+      then
+        SQLite.execute
+          conn
+          "UPDATE payment_category SET category = ?, edited_at = ? WHERE name = ?"
+          (categoryId, now, formatPaymentName newName)
+      else do
+        SQLite.execute
+          conn
+          "INSERT INTO payment_category (name, category, created_at) VALUES (?, ?, ?)"
+          (formatPaymentName newName, categoryId, now)
+  )
+  where
+    formatPaymentName :: Text -> Text
+    formatPaymentName = T.unaccent . T.toLower
diff --git a/server/src/Model/Query.hs b/server/src/Model/Query.hs
new file mode 100644
index 0000000..d15fb5f
--- /dev/null
+++ b/server/src/Model/Query.hs
@@ -0,0 +1,32 @@
+module Model.Query
+  ( Query(..)
+  , run
+  ) where
+
+import Data.Functor (Functor)
+import Database.SQLite.Simple (Connection)
+import qualified Database.SQLite.Simple as SQLite
+
+data Query a = Query (Connection -> IO a)
+
+instance Functor Query where
+  fmap f (Query call) = Query (fmap f . call)
+
+instance Applicative Query where
+  pure x = Query (const $ return x)
+  (Query callF) <*> (Query callX) = Query (\conn -> do
+    x <- callX conn
+    f <- callF conn
+    return (f x))
+
+instance Monad Query where
+  (Query callX) >>= f = Query (\conn -> do
+    x <- callX conn
+    case f x of Query callY -> callY conn)
+
+run :: Query a -> IO a
+run (Query call) = do
+  conn <- SQLite.open "database"
+  result <- call conn
+  _ <- SQLite.close conn
+  return result
diff --git a/server/src/Model/SignIn.hs b/server/src/Model/SignIn.hs
new file mode 100644
index 0000000..c5182f0
--- /dev/null
+++ b/server/src/Model/SignIn.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Model.SignIn
+  ( SignIn(..)
+  , createSignInToken
+  , getSignIn
+  , signInTokenToUsed
+  , isLastTokenValid
+  ) where
+
+import Data.Int (Int64)
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime)
+import Data.Time.Clock (UTCTime)
+import Database.SQLite.Simple (Only(Only), FromRow(fromRow))
+import qualified Database.SQLite.Simple as SQLite
+
+import Model.Query (Query(Query))
+import Model.UUID (generateUUID)
+
+type SignInId = Int64
+
+data SignIn = SignIn
+  { id :: SignInId
+  , token :: Text
+  , creation :: UTCTime
+  , email :: Text
+  , isUsed :: Bool
+  } deriving Show
+
+instance FromRow SignIn where
+  fromRow = SignIn <$>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field <*>
+    SQLite.field
+
+createSignInToken :: Text -> Query Text
+createSignInToken signInEmail =
+  Query (\conn -> do
+    now <- getCurrentTime
+    signInToken <- generateUUID
+    SQLite.execute conn "INSERT INTO sign_in (token, creation, email, is_used) VALUES (?, ?, ?, ?)" (signInToken, now, signInEmail, False)
+    return signInToken
+  )
+
+getSignIn :: Text -> Query (Maybe SignIn)
+getSignIn signInToken =
+  Query (\conn -> do
+    listToMaybe <$> (SQLite.query conn "SELECT * from sign_in WHERE token = ? LIMIT 1" (Only signInToken) :: IO [SignIn])
+  )
+
+signInTokenToUsed :: SignInId -> Query ()
+signInTokenToUsed tokenId =
+  Query (\conn ->
+    SQLite.execute conn "UPDATE sign_in SET is_used = ? WHERE id = ?" (True, tokenId)
+  )
+
+isLastTokenValid :: SignIn -> Query Bool
+isLastTokenValid signIn =
+  Query (\conn -> do
+    [ Only lastToken ] <- SQLite.query conn "SELECT token from sign_in WHERE email = ? AND is_used = ? ORDER BY creation DESC LIMIT 1" (email signIn, True)
+    return . maybe False (== (token signIn)) $ lastToken
+  )
diff --git a/server/src/Model/UUID.hs b/server/src/Model/UUID.hs
new file mode 100644
index 0000000..6cb7ce0
--- /dev/null
+++ b/server/src/Model/UUID.hs
@@ -0,0 +1,10 @@
+module Model.UUID
+  ( generateUUID
+  ) where
+
+import Data.UUID (toString)
+import Data.UUID.V4 (nextRandom)
+import Data.Text (Text, pack)
+
+generateUUID :: IO Text
+generateUUID = pack . toString <$> nextRandom
diff --git a/server/src/Model/User.hs b/server/src/Model/User.hs
new file mode 100644
index 0000000..e14fcef
--- /dev/null
+++ b/server/src/Model/User.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE OverloadedStrings    #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.User
+  ( list
+  , get
+  , create
+  , delete
+  ) where
+
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime)
+import Database.SQLite.Simple (Only(Only), FromRow(fromRow))
+import Prelude hiding (id)
+import qualified Database.SQLite.Simple as SQLite
+
+import Common.Model (UserId, User(..))
+
+import Model.Query (Query(Query))
+
+instance FromRow User where
+  fromRow = User <$> SQLite.field <*> SQLite.field <*> SQLite.field <*> SQLite.field
+
+list :: Query [User]
+list = Query (\conn -> SQLite.query_ conn "SELECT * from user ORDER BY creation DESC")
+
+get :: Text -> Query (Maybe User)
+get userEmail =
+  Query (\conn -> listToMaybe <$>
+    SQLite.query conn "SELECT * FROM user WHERE email = ? LIMIT 1" (Only userEmail)
+  )
+
+create :: Text -> Text -> Query UserId
+create userEmail userName =
+  Query (\conn -> do
+    now <- getCurrentTime
+    SQLite.execute
+      conn
+      "INSERT INTO user (creation, email, name) VALUES (?, ?, ?)"
+      (now, userEmail, userName)
+    SQLite.lastInsertRowId conn
+  )
+
+delete :: Text -> Query ()
+delete userEmail =
+  Query (\conn ->
+    SQLite.execute conn "DELETE FROM user WHERE email = ?" (Only userEmail)
+  )