diff options
| -rw-r--r-- | settlr.cabal | 3 | ||||
| -rw-r--r-- | src/Settlr/Config.hs | 1 | ||||
| -rw-r--r-- | src/Settlr/Storage.hs | 155 |
3 files changed, 142 insertions, 17 deletions
diff --git a/settlr.cabal b/settlr.cabal index d703a97..2249c68 100644 --- a/settlr.cabal +++ b/settlr.cabal @@ -17,6 +17,9 @@ executable settlr.cgi text, containers, exceptions, + time, + uuid, + directory, cgi, blaze-html default-language: Haskell2010 diff --git a/src/Settlr/Config.hs b/src/Settlr/Config.hs index 2987f8c..0686ffe 100644 --- a/src/Settlr/Config.hs +++ b/src/Settlr/Config.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} + module Settlr.Config ( Config(..) , ConfigException(..) diff --git a/src/Settlr/Storage.hs b/src/Settlr/Storage.hs index 53c29b7..8a893f6 100644 --- a/src/Settlr/Storage.hs +++ b/src/Settlr/Storage.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + module Settlr.Storage ( Group(..) , Member(..) @@ -8,50 +13,166 @@ module Settlr.Storage , createGroup , deleteGroup , Expense(..) + , expAmount + , expSaldo , getExpenses , getSaldo , addExpense ) where import Data.Text (Text) +import qualified Data.Text as T import Data.Map (Map) +import qualified Data.Map as M +import Data.UUID (UUID) +import Data.Maybe (fromMaybe) +import Data.Time (UTCTime) +import Control.Monad.Catch (MonadThrow, throwM) +import Text.Read (readMaybe) +import Control.Exception (Exception, try, IOException) +import Data.List (find, stripPrefix) +import Data.Maybe (mapMaybe) +import Settlr.Scripts (ScriptM) +import Control.Monad.Reader (asks, MonadIO (liftIO)) +import Settlr.Config (Config(..)) +import Network.CGI (formDecode, formEncode) +import Data.UUID.V4 (nextRandom) +import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) -- Identifier of a group. -newtype Group = Group Text +newtype Group = Group UUID + deriving (Eq, Ord, Show) -- Identifier of a group member. newtype Member = Member Text + deriving (Eq, Ord, Show) -- An amount of money in a particular currency (usually, the smallest unit for the currency). newtype Money = Money Int + deriving (Eq, Ord, Num, Show) -data Currency = CurrencyEUR | CurrencyUSD +data Currency = EUR | USD + deriving (Eq, Show, Read) data GroupMetadata = GroupMetadata - { grpName :: !Text - , grpMembers :: ![Member] - , grpCurrency :: !Currency + { grpName :: !Text + , grpCreatedAt :: !UTCTime + , grpCurrency :: !Currency + , grpMembers :: ![Member] } + deriving (Show) -getMetadata :: Group -> IO GroupMetadata -getMetadata = undefined +getMetadata :: Group -> ScriptM (Maybe GroupMetadata) +getMetadata grp = do basePath <- groupPath grp + readEncoded (basePath ++ "/metadata") -createGroup :: GroupMetadata -> IO Group -createGroup = undefined +createGroup :: GroupMetadata -> ScriptM Group +createGroup meta = do grp <- Group <$> liftIO nextRandom + basePath <- groupPath grp + liftIO $ createDirectoryIfMissing True basePath + writeEncoded (basePath ++ "/metadata") meta + pure grp -deleteGroup :: Group -> IO () -deleteGroup = undefined +deleteGroup :: Group -> ScriptM () +deleteGroup grp = do basePath <- groupPath grp + liftIO $ removeDirectoryRecursive basePath data Expense = Expense - { expCreditor :: !Member - , expDebtors :: !(Map Member Money) + { expDescription :: !Text + , expCreatedAt :: !UTCTime + , expCreditor :: !Member + , expDebtors :: !(Map Member Money) } + deriving (Show) + +expAmount :: Expense -> Money +expAmount expense = M.foldr (+) (Money 0) (expDebtors expense) -getExpenses :: Group -> IO [Expense] +expSaldo :: Member -> Expense -> Money +expSaldo mem expense = positiveAmount - negativeAmount + where positiveAmount = if expCreditor expense == mem + then expAmount expense + else Money 0 + negativeAmount = fromMaybe (Money 0) (M.lookup mem (expDebtors expense)) + +getExpenses :: Group -> ScriptM [Expense] getExpenses = undefined -getSaldo :: Group -> Member -> IO Money -getSaldo = undefined +getSaldo :: Member -> Group -> ScriptM Money +getSaldo mem grp = sum . fmap (expSaldo mem) <$> getExpenses grp -addExpense :: Group -> Expense -> IO () +addExpense :: Expense -> Group -> ScriptM () addExpense = undefined + +groupPath :: Group -> ScriptM FilePath +groupPath (Group grp) = do dataPath <- asks cfgDataPath + let dataPath' = fromMaybe dataPath (T.stripSuffix "/" dataPath) + pure $ T.unpack (dataPath' <> "/groups/" <> T.pack (show grp)) + +readEncoded :: Codable c => FilePath -> ScriptM (Maybe c) +readEncoded path = liftIO (try (readFile path) :: IO (Either IOException String)) >>= \case + Left _ -> pure Nothing + Right content -> Just <$> decode (formDecode content) + +writeEncoded :: Codable c => FilePath -> c -> ScriptM () +writeEncoded path content = liftIO $ writeFile path (formEncode (encode content)) + +class Codable a where + encode :: a -> [(String, String)] + decode :: MonadThrow m => [(String, String)] -> m a + +instance Codable GroupMetadata where + encode grp = [ ("name" , T.unpack (grpName grp)) + , ("createdAt", show (grpCreatedAt grp)) + , ("currency" , show (grpCurrency grp)) + ] ++ + fmap (\(Member x) -> ("member", T.unpack x)) (grpMembers grp) + decode rec = do name <- T.pack <$> lookupThrow "name" rec + createdAt <- readThrow =<< lookupThrow "createdAt" rec + currency <- readThrow =<< lookupThrow "currency" rec + let members = (Member . T.pack <$> lookupMany "member" rec) + pure $ GroupMetadata { grpName = name + , grpCreatedAt = createdAt + , grpCurrency = currency + , grpMembers = members + } + +instance Codable Expense where + encode expense = [ ("description", T.unpack (expDescription expense)) + , ("createdAt" , show (expCreatedAt expense)) + , ("creditor" , (\(Member x) -> T.unpack x) (expCreditor expense)) + ] ++ + fmap (\(Member x, Money y) -> ("debtor" ++ T.unpack x, show y)) (M.toList (expDebtors expense)) + decode rec = do description <- T.pack <$> lookupThrow "description" rec + createdAt <- readThrow =<< lookupThrow "createdAt" rec + creditor <- Member . T.pack <$> lookupThrow "creditor" rec + let debtorItems = mapMaybe (\(x, y) -> (, y) <$> stripPrefix "debtor" x) rec + debtors <- mapM (\(x, y) -> (Member (T.pack x), ) . Money <$> readThrow y) debtorItems + pure $ Expense { expDescription = description + , expCreatedAt = createdAt + , expCreditor = creditor + , expDebtors = M.fromList debtors + } + +data CodingException + = CodingInvalidValue !String + | CodingMissingKey !String + +instance Show CodingException where + show (CodingInvalidValue val) = "Decoding failed: Invalid value \"" ++ val ++ "\"" + show (CodingMissingKey key) = "Decoding failed: Invalid key \"" ++ key ++ "\"" + +instance Exception CodingException + +readThrow :: MonadThrow m => Read a => String -> m a +readThrow str = case readMaybe str of + Just x -> pure x + Nothing -> throwM (CodingInvalidValue str) + +lookupThrow :: MonadThrow m => String -> [(String, String)] -> m String +lookupThrow key rec = case find (\(x, _) -> x == key) rec of + Just (_, y) -> pure y + Nothing -> throwM (CodingMissingKey key) + +lookupMany :: String -> [(String, String)] -> [String] +lookupMany key rec = snd <$> filter (\(x, _) -> x == key) rec |