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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
module Settlr.Storage
( Group(..)
, Member(..)
, Money(..)
, Currency(..)
, GroupMetadata(..)
, getMetadata
, 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 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 = EUR | USD
deriving (Eq, Show, Read)
data GroupMetadata = GroupMetadata
{ grpName :: !Text
, grpCreatedAt :: !UTCTime
, grpCurrency :: !Currency
, grpMembers :: ![Member]
}
deriving (Show)
getMetadata :: Group -> ScriptM (Maybe GroupMetadata)
getMetadata grp = do basePath <- groupPath grp
readEncoded (basePath ++ "/metadata")
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 -> ScriptM ()
deleteGroup grp = do basePath <- groupPath grp
liftIO $ removeDirectoryRecursive basePath
data Expense = Expense
{ expDescription :: !Text
, expCreatedAt :: !UTCTime
, expCreditor :: !Member
, expDebtors :: !(Map Member Money)
}
deriving (Show)
expAmount :: Expense -> Money
expAmount expense = M.foldr (+) (Money 0) (expDebtors 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 :: Member -> Group -> ScriptM Money
getSaldo mem grp = sum . fmap (expSaldo mem) <$> getExpenses grp
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
|
