diff options
| author | Joris | 2017-11-08 23:47:26 +0100 |
|---|---|---|
| committer | Joris | 2017-11-08 23:47:26 +0100 |
| commit | 27e11b20b06f2f2dbfb56c0998a63169b4b8abc4 (patch) | |
| tree | 845f54d7fe876c9a3078036975ba85ec21d224a1 /src | |
| parent | a3601b5e6f5a3e41fa31752a2c704ccd3632790e (diff) | |
| download | budget-27e11b20b06f2f2dbfb56c0998a63169b4b8abc4.tar.gz budget-27e11b20b06f2f2dbfb56c0998a63169b4b8abc4.tar.bz2 budget-27e11b20b06f2f2dbfb56c0998a63169b4b8abc4.zip | |
Use a better project structure
Diffstat (limited to 'src')
92 files changed, 0 insertions, 5542 deletions
diff --git a/src/client/Common b/src/client/Common deleted file mode 120000 index 60d3b0a..0000000 --- a/src/client/Common +++ /dev/null @@ -1 +0,0 @@ -../common
\ No newline at end of file diff --git a/src/client/Component/Button.hs b/src/client/Component/Button.hs deleted file mode 100644 index f21798c..0000000 --- a/src/client/Component/Button.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} - -module Component.Button - ( ButtonIn(..) - , buttonInDefault - , ButtonOut(..) - , button - ) where - -import qualified Data.Map as M -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R - -import qualified Icon - -data ButtonIn t m = ButtonIn - { _buttonIn_class :: Text - , _buttonIn_content :: m () - , _buttonIn_waiting :: Event t Bool - } - -buttonInDefault :: forall t m. MonadWidget t m => ButtonIn t m -buttonInDefault = ButtonIn - { _buttonIn_class = "" - , _buttonIn_content = R.blank - , _buttonIn_waiting = R.never - } - -data ButtonOut t = ButtonOut - { _buttonOut_clic :: Event t () - } - -button :: forall t m. MonadWidget t m => ButtonIn t m -> m (ButtonOut t) -button buttonIn = do - attr <- R.holdDyn - (M.fromList [("type", "button"), ("class", _buttonIn_class buttonIn)]) - (fmap - (\w -> M.fromList $ - [ ("type", "button") ] - <> if w - then [("class", T.concat [ _buttonIn_class buttonIn, " waiting" ])] - else [("class", _buttonIn_class buttonIn)]) - (_buttonIn_waiting buttonIn)) - (e, _) <- R.elDynAttr' "button" attr $ do - Icon.loading - R.divClass "content" $ _buttonIn_content buttonIn - return $ ButtonOut - { _buttonOut_clic = R.domEvent R.Click e - } diff --git a/src/client/Component/Input.hs b/src/client/Component/Input.hs deleted file mode 100644 index 7111630..0000000 --- a/src/client/Component/Input.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} - -module Component.Input - ( InputIn(..) - , InputOut(..) - , input - ) where - -import Data.Text (Text) -import Reflex.Dom (MonadWidget, Dynamic, Event, (&), (.~), (=:)) -import qualified Reflex.Dom as R - -data InputIn t a b = InputIn - { _inputIn_reset :: Event t a - , _inputIn_placeHolder :: Text - } - -data InputOut t = InputOut - { _inputOut_value :: Dynamic t Text - , _inputOut_enter :: Event t () - } - -input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t) -input inputIn = do - let placeHolder = R.constDyn ("placeHolder" =: _inputIn_placeHolder inputIn) - let value = fmap (const "") (_inputIn_reset inputIn) - textInput <- R.textInput $ R.def & R.attributes .~ placeHolder - & R.setValue .~ value - let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput - return $ InputOut - { _inputOut_value = R._textInput_value textInput - , _inputOut_enter = enter - } diff --git a/src/client/Debug.hs b/src/client/Debug.hs deleted file mode 100644 index 0c5c979..0000000 --- a/src/client/Debug.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Debug - ( event - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Reflex.Dom (MonadWidget, Event, Dynamic) -import qualified Reflex.Dom as R - -event :: forall t m a. MonadWidget t m => Text -> Event t a -> m () -event name e = do - count <- R.count e :: m (Dynamic t Int) - let text = fmap (\c -> T.concat [name, " ", (T.pack . show $ c)]) count - R.el "div" $ R.dynText text diff --git a/src/client/Icon.hs b/src/client/Icon.hs deleted file mode 100644 index 7223def..0000000 --- a/src/client/Icon.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} - -module Icon - ( loading - , signOut - , clone - , edit - , delete - ) where - -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R - -loading :: forall t m. MonadWidget t m => m () -loading = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24"), ("class", "loader") ]) $ - svgAttr "path" (M.fromList [("d", "M13.75 22c0 .966-.783 1.75-1.75 1.75s-1.75-.784-1.75-1.75.783-1.75 1.75-1.75 1.75.784 1.75 1.75zm-1.75-22c-1.104 0-2 .896-2 2s.896 2 2 2 2-.896 2-2-.896-2-2-2zm10 10.75c.689 0 1.249.561 1.249 1.25 0 .69-.56 1.25-1.249 1.25-.69 0-1.249-.559-1.249-1.25 0-.689.559-1.25 1.249-1.25zm-22 1.25c0 1.105.896 2 2 2s2-.895 2-2c0-1.104-.896-2-2-2s-2 .896-2 2zm19-8c.551 0 1 .449 1 1 0 .553-.449 1.002-1 1-.551 0-1-.447-1-.998 0-.553.449-1.002 1-1.002zm0 13.5c.828 0 1.5.672 1.5 1.5s-.672 1.501-1.502 1.5c-.826 0-1.498-.671-1.498-1.499 0-.829.672-1.501 1.5-1.501zm-14-14.5c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2zm0 14c1.104 0 2 .896 2 2s-.896 2-2.001 2c-1.103 0-1.999-.895-1.999-2s.896-2 2-2z")]) $ R.blank - -signOut :: forall t m. MonadWidget t m => m () -signOut = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M16 9v-4l8 7-8 7v-4h-8v-6h8zm-2 10v-.083c-1.178.685-2.542 1.083-4 1.083-4.411 0-8-3.589-8-8s3.589-8 8-8c1.458 0 2.822.398 4 1.083v-2.245c-1.226-.536-2.577-.838-4-.838-5.522 0-10 4.477-10 10s4.478 10 10 10c1.423 0 2.774-.302 4-.838v-2.162z")]) $ R.blank - -clone :: forall t m. MonadWidget t m => m () -clone = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank - -edit :: forall t m. MonadWidget t m => m () -edit = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M18.363 8.464l1.433 1.431-12.67 12.669-7.125 1.436 1.439-7.127 12.665-12.668 1.431 1.431-12.255 12.224-.726 3.584 3.584-.723 12.224-12.257zm-.056-8.464l-2.815 2.817 5.691 5.692 2.817-2.821-5.693-5.688zm-12.318 18.718l11.313-11.316-.705-.707-11.313 11.314.705.709z")]) $ R.blank - -delete :: forall t m. MonadWidget t m => m () -delete = - svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ - svgAttr "path" (M.fromList [("d", "M3 6v18h18v-18h-18zm5 14c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm5 0c0 .552-.448 1-1 1s-1-.448-1-1v-10c0-.552.448-1 1-1s1 .448 1 1v10zm4-18v2h-20v-2h5.711c.9 0 1.631-1.099 1.631-2h5.315c0 .901.73 2 1.631 2h5.712z")]) $ R.blank - -svgAttr :: forall t m a. MonadWidget t m => Text -> Map Text Text -> m a -> m a -svgAttr elementTag attrs child = R.elWith elementTag (R.ElConfig (Just "http://www.w3.org/2000/svg") attrs) child diff --git a/src/client/Main.hs b/src/client/Main.hs deleted file mode 100644 index c5f2c50..0000000 --- a/src/client/Main.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Main - ( main - ) where - -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as LB -import Data.JSString.Text (textFromJSString) -import qualified Data.Text.Encoding as T -import qualified GHCJS.DOM as Dom -import qualified GHCJS.DOM.NonElementParentNode as Dom -import GHCJS.DOM.Types (JSM, Element, JSString) -import Prelude hiding (init, error) - -import Common.Model (InitResult(InitEmpty)) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key - -import qualified View.App as App - -main :: JSM () -main = do - initResult <- readInit - putStrLn . show $ initResult - App.widget initResult - -readInit :: JSM InitResult -readInit = do - document <- Dom.currentDocumentUnchecked - initNode <- Dom.getElementById document "init" - case initNode of - Just node -> do - text <- textFromJSString <$> js_getInnerText node - return $ case Aeson.decode (LB.fromStrict . T.encodeUtf8 $ text) of - Just init -> init - Nothing -> initParseError - _ -> - return initParseError - where initParseError = InitEmpty (Left $ Message.get Key.SignIn_ParseError) - -foreign import javascript unsafe "$1[\"innerText\"]" - js_getInnerText :: Element -> IO JSString diff --git a/src/client/View/App.hs b/src/client/View/App.hs deleted file mode 100644 index 1466811..0000000 --- a/src/client/View/App.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module View.App - ( widget - ) where - -import qualified Reflex.Dom as R -import Prelude hiding (init, error) - -import Common.Model (InitResult(..)) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key - -import View.Header (HeaderIn(..)) -import View.Payment (PaymentIn(..)) -import qualified View.Header as Header -import qualified View.Payment as Payment -import qualified View.SignIn as SignIn - -widget :: InitResult -> IO () -widget initResult = - R.mainWidget $ do - headerOut <- Header.view $ HeaderIn - { _headerIn_initResult = initResult - } - - let signOut = Header._headerOut_signOut headerOut - - initialContent = case initResult of - InitSuccess initSuccess -> do - _ <- Payment.widget $ PaymentIn - { _paymentIn_init = initSuccess - } - return () - InitEmpty result -> - SignIn.view result - - signOutContent = SignIn.view (Right . Just $ Message.get Key.SignIn_DisconnectSuccess) - - _ <- R.widgetHold initialContent (fmap (const signOutContent) signOut) - - R.blank diff --git a/src/client/View/Header.hs b/src/client/View/Header.hs deleted file mode 100644 index 32738f1..0000000 --- a/src/client/View/Header.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module View.Header - ( view - , HeaderIn(..) - , HeaderOut(..) - ) where - -import qualified Data.Map as M -import Data.Time (NominalDiffTime) -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R -import Prelude hiding (init, error) - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), Init(..), User(..)) -import qualified Common.Model.User as User - -import Component.Button (ButtonIn(..)) -import qualified Component.Button as Component -import qualified Icon - -data HeaderIn = HeaderIn - { _headerIn_initResult :: InitResult - } - -data HeaderOut t = HeaderOut - { _headerOut_signOut :: Event t () - } - -view :: forall t m. MonadWidget t m => HeaderIn -> m (HeaderOut t) -view headerIn = - R.el "header" $ do - - R.divClass "title" $ - R.text $ Message.get Key.App_Title - - signOut <- nameSignOut $ _headerIn_initResult headerIn - - return $ HeaderOut - { _headerOut_signOut = signOut - } - -nameSignOut :: forall t m. MonadWidget t m => InitResult -> m (Event t ()) -nameSignOut initResult = case initResult of - (InitSuccess init) -> do - rec - attr <- R.holdDyn - (M.singleton "class" "nameSignOut") - (fmap (const $ M.fromList [("style", "visibility: hidden"), ("class", "nameSignOut")]) signOut) - - signOut <- R.elDynAttr "nameSignOut" attr $ do - case User.find (_init_currentUser init) (_init_users init) of - Just user -> R.divClass "name" $ R.text (_user_name user) - Nothing -> R.blank - signOutButton - - return signOut - _ -> - return R.never - -signOutButton :: forall t m. MonadWidget t m => m (Event t ()) -signOutButton = do - rec - signOut <- Component.button $ ButtonIn - { Component._buttonIn_class = "signOut item" - , Component._buttonIn_content = Icon.signOut - , Component._buttonIn_waiting = waiting - } - let signOutClic = Component._buttonOut_clic signOut - waiting = R.leftmost - [ fmap (const True) signOutClic - , fmap (const False) signOutSuccess - ] - signOutSuccess <- askSignOut signOutClic >>= R.debounce (0.5 :: NominalDiffTime) - - return . fmap (const ()) . R.ffilter (== True) $ signOutSuccess - - where askSignOut :: forall t m. MonadWidget t m => Event t () -> m (Event t Bool) - askSignOut signOut = - fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = fmap (const $ R.postJson "/signOut" ()) signOut - getResult = (== 200) . R._xhrResponse_status diff --git a/src/client/View/Payment.hs b/src/client/View/Payment.hs deleted file mode 100644 index e80790b..0000000 --- a/src/client/View/Payment.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module View.Payment - ( widget - , PaymentIn(..) - , PaymentOut(..) - ) where - -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R - -import Common.Model (Init) - -import View.Payment.Table (TableIn(..)) -import qualified View.Payment.Table as Table - -data PaymentIn = PaymentIn - { _paymentIn_init :: Init - } - -data PaymentOut = PaymentOut - { - } - -widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut -widget paymentIn = do - R.divClass "payment" $ do - _ <- Table.widget $ TableIn - { _tableIn_init = _paymentIn_init paymentIn - } - return $ PaymentOut {} diff --git a/src/client/View/Payment/Table.hs b/src/client/View/Payment/Table.hs deleted file mode 100644 index 878e7da..0000000 --- a/src/client/View/Payment/Table.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module View.Payment.Table - ( widget - , TableIn(..) - , TableOut(..) - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.List as L -import qualified Data.Map as M -import Prelude hiding (init) -import Reflex.Dom (MonadWidget) -import qualified Reflex.Dom as R - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Payment(..), PaymentCategory(..), Category(..), User(..), Init(..)) -import qualified Common.Model.User as User -import qualified Common.Util.Text as T -import qualified Common.View.Format as Format - -import qualified Icon - -data TableIn = TableIn - { _tableIn_init :: Init - } - -data TableOut = TableOut - { - } - -widget :: forall t m. MonadWidget t m => TableIn -> m TableOut -widget tableIn = do - R.divClass "table" $ - R.divClass "lines" $ do - R.divClass "header" $ do - R.divClass "cell name" $ R.text $ Message.get Key.Payment_Name - R.divClass "cell cost" $ R.text $ Message.get Key.Payment_Cost - R.divClass "cell user" $ R.text $ Message.get Key.Payment_User - R.divClass "cell category" $ R.text $ Message.get Key.Payment_Category - R.divClass "cell date" $ R.text $ Message.get Key.Payment_Date - R.divClass "cell" $ R.blank - R.divClass "cell" $ R.blank - R.divClass "cell" $ R.blank - let init = _tableIn_init tableIn - payments = _init_payments init - mapM_ - (paymentRow init) - (take 8 . reverse . L.sortOn _payment_date $ payments) - return $ TableOut {} - -paymentRow :: forall t m. MonadWidget t m => Init -> Payment -> m () -paymentRow init payment = - R.divClass "row" $ do - R.divClass "cell name" . R.text $ _payment_name payment - R.divClass "cell cost" . R.text . Format.price (_init_currency init) $ _payment_cost payment - R.divClass "cell user" $ - case User.find (_payment_user payment) (_init_users init) of - Just user -> R.text (_user_name user) - _ -> R.blank - R.divClass "cell category" $ - case findCategory (_init_categories init) (_init_paymentCategories init) (_payment_name payment) of - Just category -> - R.elAttr "span" (M.fromList [("class", "tag"), ("style", T.concat [ "background-color: ", _category_color category ])]) $ - R.text $ _category_name category - _ -> - R.blank - R.divClass "cell date" $ do - R.elClass "span" "shortDate" . R.text $ Format.shortDay (_payment_date payment) - R.elClass "span" "longDate" . R.text $ Format.longDay (_payment_date payment) - R.divClass "cell button" . R.el "button" $ Icon.clone - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.edit - else R.blank - R.divClass "cell button" $ - if _payment_user payment == (_init_currentUser init) - then R.el "button" $ Icon.delete - else R.blank - -findCategory :: [Category] -> [PaymentCategory] -> Text -> Maybe Category -findCategory categories paymentCategories paymentName = do - paymentCategory <- L.find - ((== (T.unaccent . T.toLower) paymentName) . _paymentCategory_name) - paymentCategories - L.find ((== (_paymentCategory_category paymentCategory)) . _category_id) categories diff --git a/src/client/View/SignIn.hs b/src/client/View/SignIn.hs deleted file mode 100644 index e164ee7..0000000 --- a/src/client/View/SignIn.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} - -module View.SignIn - ( view - ) where - -import qualified Data.Either as Either -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time (NominalDiffTime) -import Prelude hiding (error) -import Reflex.Dom (MonadWidget, Event) -import qualified Reflex.Dom as R - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (SignIn(SignIn)) - -import Component.Input (InputIn(..), InputOut(..)) -import Component.Button (ButtonIn(..), ButtonOut(..)) -import qualified Component.Button as Component -import qualified Component.Input as Component - -view :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> m () -view result = - R.divClass "signIn" $ do - rec - input <- Component.input $ InputIn - { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_placeHolder = Message.get Key.SignIn_EmailPlaceholder - } - - let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button - - dynValidatedEmail <- R.holdDyn False . R.mergeWith (\_ _ -> False) $ - [ fmap (const True) userWantsEmailValidation - , fmap (const False) signInResult - ] - - uniqDynValidatedEmail <- R.holdUniqDyn dynValidatedEmail - - let validatedEmail = R.tagPromptlyDyn - (_inputOut_value input) - (R.ffilter (== True) . R.updated $ uniqDynValidatedEmail) - - let waiting = R.leftmost - [ fmap (const True) validatedEmail - , fmap (const False) signInResult - ] - - button <- Component.button $ ButtonIn - { _buttonIn_class = "" - , _buttonIn_content = R.text (Message.get Key.SignIn_Button) - , _buttonIn_waiting = waiting - } - - signInResult <- askSignIn validatedEmail >>= R.debounce (0.5 :: NominalDiffTime) - - showSignInResult result signInResult - -askSignIn :: forall t m. MonadWidget t m => Event t Text -> m (Event t (Either Text Text)) -askSignIn email = - fmap getResult <$> R.performRequestAsync xhrRequest - where xhrRequest = fmap (R.postJson "/signIn" . SignIn) email - getResult response = - case R._xhrResponse_responseText response of - Just key -> - if R._xhrResponse_status response == 200 then Right key else Left key - _ -> Left "NoKey" - -showSignInResult :: forall t m. MonadWidget t m => Either Text (Maybe Text) -> Event t (Either Text Text) -> m () -showSignInResult result signInResult = do - _ <- R.widgetHold (showInitResult result) $ R.ffor signInResult showResult - R.blank - - where showInitResult (Left error) = showError error - showInitResult (Right (Just success)) = showSuccess success - showInitResult (Right Nothing) = R.blank - - showResult (Left error) = showError error - showResult (Right success) = showSuccess success - - showError = R.divClass "error" . R.text - showSuccess = R.divClass "success" . R.text diff --git a/src/common/Message.hs b/src/common/Message.hs deleted file mode 100644 index 9ae735d..0000000 --- a/src/common/Message.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Common.Message - ( get - ) where - -import Data.Text (Text) - -import Common.Message.Key (Key) -import Common.Message.Lang (Lang(..)) -import qualified Common.Message.Translation as Translation - -get :: Key -> Text -get = Translation.get French diff --git a/src/common/Message/Key.hs b/src/common/Message/Key.hs deleted file mode 100644 index 4127808..0000000 --- a/src/common/Message/Key.hs +++ /dev/null @@ -1,152 +0,0 @@ -module Common.Message.Key - ( Key(..) - ) where - -import Data.Text - -data Key = - - App_Title - - | Category_Add - | Category_Clone - | Category_Color - | Category_DeleteConfirm - | Category_Edit - | Category_Empty - | Category_Name - | Category_NotDeleted - | Category_Title - | Category_Used - - | Date_Long Int Text Int - | Date_Short Int Int Int - | Date_ShortMonthAndYear Int Int - - | Dialog_Confirm - | Dialog_Undo - - | Error_CategoryCreate - | Error_CategoryDelete - | Error_CategoryEdit - | Error_IncomeCreate - | Error_IncomeDelete - | Error_IncomeEdit - | Error_PaymentCreate - | Error_PaymentDelete - | Error_PaymentEdit - | Error_SignOut - - | Form_AlreadyExists - | Form_CostMustNotBeNull - | Form_Empty - | Form_GreaterIntThan Int - | Form_InvalidCategory - | Form_InvalidColor - | Form_InvalidDate - | Form_InvalidInt - | Form_InvalidString - | Form_SmallerIntThan Int - - | HttpError_BadPayload - | HttpError_BadUrl - | HttpError_NetworkError - | HttpError_Timeout - - | Income_AddLong - | Income_AddShort - | Income_Amount - | Income_Clone - | Income_CumulativeSince Text - | Income_Date - | Income_DeleteConfirm - | Income_Edit - | Income_Empty - | Income_MonthlyNet - | Income_NotDeleted - | Income_Title - - | Month_January - | Month_February - | Month_March - | Month_April - | Month_May - | Month_June - | Month_July - | Month_August - | Month_September - | Month_October - | Month_November - | Month_December - - | PageNotFound_Title - - | Payment_Add - | Payment_Balanced - | Payment_Category - | Payment_CloneLong - | Payment_CloneShort - | Payment_Cost - | Payment_Date - | Payment_Delete - | Payment_DeleteConfirm - | Payment_EditLong - | Payment_EditShort - | Payment_Empty - | Payment_Frequency - | Payment_InvalidFrequency - | Payment_Many - | Payment_MonthlyFemale - | Payment_MonthlyMale - | Payment_Name - | Payment_NotDeleted - | Payment_One - | Payment_PunctualFemale - | Payment_PunctualMale - | Payment_Title - | Payment_User - | Payment_Worth Text Text - - | Search_Monthly - | Search_Name - | Search_Punctual - - | Secure_Forbidden - | Secure_Unauthorized - - | SignIn_Button - | SignIn_DisconnectSuccess - | SignIn_EmailInvalid - | SignIn_EmailPlaceholder - | SignIn_EmailSendFail - | SignIn_EmailSent - | SignIn_LinkExpired - | SignIn_LinkInvalid - | SignIn_LinkUsed - | SignIn_MailTitle - | SignIn_MailBody Text Text - | SignIn_ParseError - - | Statistic_Title - | Statistic_ByMonthsAndMean Text - | Statistic_By Text Text - | Statistic_Total - - | WeeklyReport_Empty - | WeeklyReport_IncomesCreated Int - | WeeklyReport_IncomesDeleted Int - | WeeklyReport_IncomesEdited Int - | WeeklyReport_IncomeCreated Int - | WeeklyReport_IncomeDeleted Int - | WeeklyReport_IncomeEdited Int - | WeeklyReport_PayedFor Text Text Text Text - | WeeklyReport_PayedForNot Text Text Text Text - | WeeklyReport_PayedFrom Text Text Text - | WeeklyReport_PayedFromNot Text Text Text - | WeeklyReport_PaymentsCreated Int - | WeeklyReport_PaymentsDeleted Int - | WeeklyReport_PaymentsEdited Int - | WeeklyReport_PaymentCreated Int - | WeeklyReport_PaymentDeleted Int - | WeeklyReport_PaymentEdited Int - | WeeklyReport_Title diff --git a/src/common/Message/Lang.hs b/src/common/Message/Lang.hs deleted file mode 100644 index 0a32ede..0000000 --- a/src/common/Message/Lang.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Common.Message.Lang - ( Lang(..) - ) where - -data Lang = - English - | French diff --git a/src/common/Message/Translation.hs b/src/common/Message/Translation.hs deleted file mode 100644 index 900a9e9..0000000 --- a/src/common/Message/Translation.hs +++ /dev/null @@ -1,697 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Common.Message.Translation - ( get - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -import Common.Message.Key -import Common.Message.Lang (Lang(..)) - -get :: Lang -> Key -> Text -get = m - -m :: Lang -> Key -> Text - -m l App_Title = - case l of - English -> "Shared Cost" - French -> "Partage des frais" - -m l Category_Add = - case l of - English -> "Add an category" - French -> "Ajouter une catégorie" - -m l Category_Clone = - case l of - English -> "Clone an category" - French -> "Cloner une catégorie" - -m l Category_Color = - case l of - English -> "Color" - French -> "Couleur" - -m l Category_DeleteConfirm = - case l of - English -> "Are you sure to delete this category ?" - French -> "Voulez-vous vraiment supprimer cette catégorie ?" - -m l Category_Edit = - case l of - English -> "Edit an category" - French -> "Modifier une catégorie" - -m l Category_Empty = - case l of - English -> "No category." - French -> "Aucune catégorie." - -m l Category_Name = - case l of - English -> "Name" - French -> "Nom" - -m l Category_NotDeleted = - case l of - English -> "The category could not have been deleted." - French -> "La catégorie n’a pas pu être supprimé." - -m l Category_Title = - case l of - English -> "Categories" - French -> "Catégories" - -m l Category_Used = - case l of - English -> "This category is currently being used" - French -> "Cette catégorie est actuellement utilisée" - -m l (Date_Short day month year) = - case l of - English -> - T.intercalate "-" [ padded year 4, padded month 2, padded day 2 ] - French -> - T.intercalate "/" [ padded day 2, padded month 2, padded year 4 ] - where padded num pad = - let str = show num - in T.pack $ replicate (pad - length str) '0' ++ str - -m l (Date_ShortMonthAndYear month year) = - case l of - English -> - T.intercalate "-" . map (T.pack . show) $ [ year, month ] - French -> - T.intercalate "/" . map (T.pack . show) $ [ month, year ] - -m l (Date_Long day month year) = - case l of - English -> - T.concat [ month, " " , T.pack . show $ day, ", ", T.pack . show $ year ] - French -> - T.intercalate " " [ T.pack . show $ day, month, T.pack . show $ year ] - -m l Dialog_Confirm = - case l of - English -> "Confirm" - French -> "Confirmer" - -m l Dialog_Undo = - case l of - English -> "Undo" - French -> "Annuler" - -m l Error_CategoryCreate = - case l of - English -> "Error at category creation" - French -> "Erreur lors de la création de la catégorie" - -m l Error_CategoryDelete = - case l of - English -> "Error at category deletion" - French -> "Erreur lors de la suppression de la catégorie" - -m l Error_CategoryEdit = - case l of - English -> "Error at category edition" - French -> "Erreur lors de la modification de la catégorie" - -m l Error_IncomeCreate = - case l of - English -> "Error at income creation" - French -> "Erreur lors de la création du revenu" - -m l Error_IncomeDelete = - case l of - English -> "Error at income deletion" - French -> "Erreur lors de la suppression du revenu" - -m l Error_IncomeEdit = - case l of - English -> "Error at income edition" - French -> "Erreur lors de la modification du revenu" - -m l Error_PaymentCreate = - case l of - English -> "Error at payment creation" - French -> "Erreur lors de la création du paiement" - -m l Error_PaymentDelete = - case l of - English -> "Error at payment deletion" - French -> "Erreur lors de la suppression du paiement" - -m l Error_PaymentEdit = - case l of - English -> "Error at payment edition" - French -> "Erreur lors de la modification du paiement" - -m l Error_SignOut = - case l of - English -> "Error at sign out" - French -> "Erreur lors de la déconnexion" - -m l Form_AlreadyExists = - case l of - English -> "Dupplicate field" - French -> "Doublon" - -m l Form_CostMustNotBeNull = - case l of - English -> "Cost must not be zero" - French -> "Le coût ne doît pas être nul" - -m l Form_Empty = - case l of - English -> "Required field" - French -> "Champ requis" - -m l (Form_GreaterIntThan number) = - case l of - English -> T.concat [ "Integer smaller than ", T.pack . show $ number, " or equal required" ] - French -> T.concat [ "Entier inférieur ou égal à ", T.pack . show $ number, " requis" ] - -m l Form_InvalidCategory = - case l of - English -> "Invalid category" - French -> "Catégorie invalide" - -m l Form_InvalidColor = - case l of - English -> "Invalid color" - French -> "Couleur invalide" - -m l Form_InvalidDate = - case l of - English -> "day/month/year required" - French -> "jour/mois/année requis" - -m l Form_InvalidInt = - case l of - English -> "Integer required" - French -> "Entier requis" - -m l Form_InvalidString = - case l of - English -> "String required" - French -> "Chaîne de caractères requise" - -m l (Form_SmallerIntThan number) = - case l of - English -> T.concat [ "Integer bigger than ", T.pack . show $ number, " or equal required" ] - French -> T.concat [ "Entier supérieur ou égal à ", T.pack . show $ number, " requis" ] - -m l HttpError_BadPayload = - case l of - English -> "Bad payload server error" - French -> "Contenu inattendu en provenance du serveur" - -m l HttpError_BadUrl = - case l of - English -> "URL not valid" - French -> "l’URL n’est pas valide" - -m l HttpError_NetworkError = - case l of - English -> "Network can not be reached" - French -> "Le serveur n’est pas accessible" - -m l HttpError_Timeout = - case l of - English -> "Timeout server error" - French -> "Le serveur met trop de temps à répondre" - -m l Income_AddLong = - case l of - English -> "Add an income" - French -> "Ajouter un revenu" - -m l Income_AddShort = - case l of - English -> "Add" - French -> "Ajouter" - -m l Income_Amount = - case l of - English -> "Amount" - French -> "Montant" - -m l Income_Clone = - case l of - English -> "Clone an income" - French -> "Cloner un revenu" - -m l (Income_CumulativeSince since) = - case l of - English -> T.concat [ "Cumulative incomes since ", since ] - French -> T.concat [ "Revenus nets cumulés depuis le ", since ] - -m l Income_Date = - case l of - English -> "Date" - French -> "Date" - -m l Income_DeleteConfirm = - case l of - English -> "Are you sure to delete this income ?" - French -> "Voulez-vous vraiment supprimer ce revenu ?" - -m l Income_Edit = - case l of - English -> "Edit an income" - French -> "Modifier un revenu" - -m l Income_Empty = - case l of - English -> "No income." - French -> "Aucun revenu." - -m l Income_MonthlyNet = - case l of - English -> "Net monthly incomes" - French -> "Revenus mensuels nets" - -m l Income_NotDeleted = - case l of - English -> "The income could not have been deleted." - French -> "Le revenu n’a pas pu être supprimé." - -m l Income_Title = - case l of - English -> "Income" - French -> "Revenu" - -m l Month_January = - case l of - English -> "january" - French -> "janvier" - -m l Month_February = - case l of - English -> "february" - French -> "février" - -m l Month_March = - case l of - English -> "march" - French -> "mars" - -m l Month_April = - case l of - English -> "april" - French -> "avril" - -m l Month_May = - case l of - English -> "may" - French -> "mai" - -m l Month_June = - case l of - English -> "june" - French -> "juin" - -m l Month_July = - case l of - English -> "july" - French -> "juillet" - -m l Month_August = - case l of - English -> "august" - French -> "août" - -m l Month_September = - case l of - English -> "september" - French -> "septembre" - -m l Month_October = - case l of - English -> "october" - French -> "octobre" - -m l Month_November = - case l of - English -> "november" - French -> "novembre" - -m l Month_December = - case l of - English -> "december" - French -> "décembre" - -m l PageNotFound_Title = - case l of - English -> "Page not found" - French -> "Page introuvable" - -m l Payment_Add = - case l of - English -> "Add a payment" - French -> "Ajouter un paiement" - -m l Payment_Balanced = - case l of - English -> "Payments are balanced." - French -> "Les paiements sont équilibrés." - -m l Payment_Category = - case l of - English -> "Category" - French -> "Catégorie" - -m l Payment_CloneLong = - case l of - English -> "Clone a payment" - French -> "Cloner un paiement" - -m l Payment_CloneShort = - case l of - English -> "Clone" - French -> "Cloner" - -m l Payment_Cost = - case l of - English -> "Cost" - French -> "Coût" - -m l Payment_Date = - case l of - English -> "Date" - French -> "Date" - -m l Payment_Delete = - case l of - English -> "Delete" - French -> "Supprimer" - -m l Payment_DeleteConfirm = - case l of - English -> "Are you sure to delete this payment ?" - French -> "Voulez-vous vraiment supprimer ce paiement ?" - -m l Payment_EditLong = - case l of - English -> "Edit a payment" - French -> "Modifier un paiement" - -m l Payment_EditShort = - case l of - English -> "Edit" - French -> "Modifier" - -m l Payment_Empty = - case l of - English -> "No payment found from your search criteria." - French -> "Aucun paiement ne correspond à vos critères de recherches." - -m l Payment_Frequency = - case l of - English -> "Frequency" - French -> "Fréquence" - -m l Payment_InvalidFrequency = - case l of - English -> "Invalid frequency" - French -> "Fréquence invalide" - -m l Payment_Many = - case l of - English -> "payments" - French -> "paiements" - -m l Payment_MonthlyFemale = - case l of - English -> "Monthly" - French -> "Mensuelle" - -m l Payment_MonthlyMale = - case l of - English -> "Monthly" - French -> "Mensuel" - -m l Payment_Name = - case l of - English -> "Name" - French -> "Nom" - -m l Payment_NotDeleted = - case l of - English -> "The payment could not have been deleted." - French -> "Le paiement n’a pas pu être supprimé." - -m l Payment_One = - case l of - English -> "payment" - French -> "paiement" - -m l Payment_PunctualFemale = - case l of - English -> "Punctual" - French -> "Ponctuelle" - -m l Payment_PunctualMale = - case l of - English -> "Punctual" - French -> "Ponctuel" - -m l Payment_Title = - case l of - English -> "Payments" - French -> "Paiements" - -m l Payment_User = - case l of - English -> "Payer" - French -> "Payeur" - -m l (Payment_Worth subject amount) = - case l of - English -> T.concat [ subject, " worth ", amount ] - French -> T.concat [ subject, " comptabilisant ", amount ] - -m l Search_Monthly = - case l of - English -> "Monthly" - French -> "Mensuel" - -m l Search_Name = - case l of - English -> "Search" - French -> "Recherche" - -m l Search_Punctual = - case l of - English -> "Punctual" - French -> "Ponctuel" - -m l Secure_Unauthorized = - case l of - English -> "You are not authorized to sign in." - French -> "Tu n’es pas autorisé à te connecter." - -m l Secure_Forbidden = - case l of - English -> "You need to be logged in to perform this action" - French -> "Tu dois te connecter pour effectuer cette action" - -m l SignIn_Button = - case l of - English -> "Sign in" - French -> "Connexion" - -m l SignIn_DisconnectSuccess = - case l of - English -> "You have successfully disconnected" - French -> "Vous êtes à présent déconnecté." - -m l SignIn_EmailInvalid = - case l of - English -> "Your email is not valid." - French -> "Votre courriel n’est pas valide." - -m l SignIn_EmailPlaceholder = - case l of - English -> "Email" - French -> "Courriel" - -m l SignIn_EmailSendFail = - case l of - English -> "You are authorized to sign in, but we failed to send you the sign up email." - French -> "Tu es autorisé à te connecter, mais nous n’avons pas pu t’envoyer le courriel de connexion." - -m l SignIn_EmailSent = - case l of - English -> "We sent you an email with a connexion link." - French -> "Nous t’avons envoyé un courriel avec un lien pour te connecter." - -m l SignIn_LinkExpired = - case l of - English -> "The link expired, please sign in again." - French -> "Le lien sur lequel tu as cliqué a expiré, connecte-toi à nouveau." - -m l SignIn_LinkInvalid = - case l of - English -> "The link is invalid, please sign in again." - French -> "Le lien sur lequel tu as cliqué est invalide, connecte-toi à nouveau." - -m l SignIn_LinkUsed = - case l of - English -> "You already used this link, please sign in again." - French -> "Tu as déjà utilisé ce lien, connecte-toi à nouveau." - -m l SignIn_MailTitle = - case l of - English -> T.concat [ "Sign in to ", m l App_Title ] - French -> T.concat [ "Connexion à ", m l App_Title ] - -m l (SignIn_MailBody name url) = - T.intercalate - "\n" - ( case l of - English -> - [ T.concat [ "Hi ", name, "," ] - , "" - , T.concat - [ "Click to the following link in order to sign in to Shared Cost:" - , m l App_Title - , ":" - ] - , url - , "" - , "See you soon!" - ] - French -> - [ T.concat [ "Salut ", name, "," ] - , "" - , T.concat - [ "Clique sur le lien suivant pour te connecter à " - , m l App_Title - , ":" - ] - , url - , "" - , "À très vite !" - ] - ) - -m l SignIn_ParseError = - case l of - English -> "Error while reading initial data." - French -> "Erreur lors de la lecture des données initiales." - -m l (Statistic_By key value) = - case l of - English -> T.concat [ key, ": ", value ] - French -> T.concat [ key, " : ", value ] - -m l (Statistic_ByMonthsAndMean amount) = - case l of - English -> - T.concat [ "Payments by category by month months (", amount, "on average)" ] - French -> - T.concat [ "Paiements par catégorie par mois (en moyenne ", amount, ")" ] - -m l Statistic_Title = - case l of - English -> "Statistics" - French -> "Statistiques" - -m l Statistic_Total = - case l of - English -> "Total" - French -> "Total" - -m l WeeklyReport_Empty = - case l of - English -> "No activity the previous week." - French -> "Pas d’activité la semaine passée." - -m l (WeeklyReport_IncomesCreated count) = - case l of - English -> T.concat [ T.pack . show $ count, " incomes created:" ] - French -> T.concat [ T.pack . show $ count, " revenus créés :" ] - -m l (WeeklyReport_IncomesDeleted count) = - case l of - English -> T.concat [ T.pack . show $ count, " incomes deleted:" ] - French -> T.concat [ T.pack . show $ count, " revenus supprimés :" ] - -m l (WeeklyReport_IncomesEdited count) = - case l of - English -> T.concat [ T.pack . show $ count, " incomes edited:" ] - French -> T.concat [ T.pack . show $ count, " revenus modifiés :" ] - -m l (WeeklyReport_IncomeCreated count) = - case l of - English -> T.concat [ T.pack . show $ count, " income created:" ] - French -> T.concat [ T.pack . show $ count, " revenu créé :" ] - -m l (WeeklyReport_IncomeDeleted count) = - case l of - English -> T.concat [ T.pack . show $ count, " income deleted:" ] - French -> T.concat [ T.pack . show $ count, " revenu supprimé :" ] - -m l (WeeklyReport_IncomeEdited count) = - case l of - English -> T.concat [ T.pack . show $ count, " income edited:" ] - French -> T.concat [ T.pack . show $ count, " revenu modifié :" ] - -m l (WeeklyReport_PayedFor name amount for at) = - case l of - English -> T.concat [ T.pack . show $ name, " payed ", amount, " for “", for, "” at ", at ] - French -> T.concat [ T.pack . show $ name, " a payé ", amount, " concernant « ", for, " » le ", at ] - -m l (WeeklyReport_PayedForNot name amount for at) = - case l of - English -> T.concat [ T.pack . show $ name, " didn’t pay ", amount, " for “", for, "” at ", at ] - French -> T.concat [ T.pack . show $ name, " n’a pas payé ", amount, " concernant « ", for, " » le ", at ] - -m l (WeeklyReport_PayedFrom name amount for) = - case l of - English -> T.concat [ T.pack . show $ name, " is payed ", amount, " of net monthly income from ", for ] - French -> T.concat [ T.pack . show $ name, " est payé ", amount, " net par mois à partir du ", for ] - -m l (WeeklyReport_PayedFromNot name amount for) = - case l of - English -> T.concat [ T.pack . show $ name, " isn’t payed ", amount, " of net monthly income from ", for ] - French -> T.concat [ T.pack . show $ name, " n’est pas payé ", amount, " net par mois à partir du ", for ] - -m l (WeeklyReport_PaymentsCreated count) = - case l of - English -> T.concat [ T.pack . show $ count, " payments created:" ] - French -> T.concat [ T.pack . show $ count, " paiements créés :" ] - -m l (WeeklyReport_PaymentsDeleted count) = - case l of - English -> T.concat [ T.pack . show $ count, " payments deleted:" ] - French -> T.concat [ T.pack . show $ count, " paiements supprimés :" ] - -m l (WeeklyReport_PaymentsEdited count) = - case l of - English -> T.concat [ T.pack . show $ count, " payments edited:" ] - French -> T.concat [ T.pack . show $ count, " paiements modifiés :" ] - -m l (WeeklyReport_PaymentCreated count) = - case l of - English -> T.concat [ T.pack . show $ count, " payment created:" ] - French -> T.concat [ T.pack . show $ count, " paiement créé :" ] - -m l (WeeklyReport_PaymentDeleted count) = - case l of - English -> T.concat [ T.pack . show $ count, " payment deleted:" ] - French -> T.concat [ T.pack . show $ count, " paiement supprimé :" ] - -m l (WeeklyReport_PaymentEdited count) = - case l of - English -> T.concat [ T.pack . show $ count, " payment edited:" ] - French -> T.concat [ T.pack . show $ count, " paiement modifié :" ] - -m l WeeklyReport_Title = - case l of - English -> "Weekly report" - French -> "Rapport hebdomadaire" diff --git a/src/common/Model.hs b/src/common/Model.hs deleted file mode 100644 index 075021f..0000000 --- a/src/common/Model.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Common.Model - ( Category(..) - , CategoryId - , CreateCategory(..) - , CreateIncome(..) - , CreatePayment(..) - , Currency(..) - , EditCategory(..) - , EditIncome(..) - , EditPayment(..) - , Frequency(..) - , Income(..) - , IncomeId - , Init(..) - , InitResult(..) - , Payment(..) - , PaymentId - , PaymentCategory(..) - , PaymentCategoryId - , SignIn(..) - , User(..) - , UserId - ) where - -import Common.Model.Category (Category(..), CategoryId) -import Common.Model.CreateCategory (CreateCategory(..)) -import Common.Model.CreateIncome (CreateIncome(..)) -import Common.Model.CreatePayment (CreatePayment(..)) -import Common.Model.Currency (Currency(..)) -import Common.Model.EditCategory (EditCategory(..)) -import Common.Model.EditIncome (EditIncome(..)) -import Common.Model.EditPayment (EditPayment(..)) -import Common.Model.Frequency (Frequency(..)) -import Common.Model.Income (Income(..), IncomeId) -import Common.Model.Init (Init(..)) -import Common.Model.InitResult (InitResult(..)) -import Common.Model.Payment (Payment(..), PaymentId) -import Common.Model.PaymentCategory (PaymentCategory(..), PaymentCategoryId) -import Common.Model.SignIn (SignIn(..)) -import Common.Model.User (User(..), UserId) diff --git a/src/common/Model/Category.hs b/src/common/Model/Category.hs deleted file mode 100644 index 53a6bdb..0000000 --- a/src/common/Model/Category.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Category - ( CategoryId - , Category(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) - -type CategoryId = Int64 - -data Category = Category - { _category_id :: CategoryId - , _category_name :: Text - , _category_color :: Text - , _category_createdAt :: UTCTime - , _category_editedAt :: Maybe UTCTime - , _category_deletedAt :: Maybe UTCTime - } deriving (Show, Generic) - -instance FromJSON Category -instance ToJSON Category diff --git a/src/common/Model/CreateCategory.hs b/src/common/Model/CreateCategory.hs deleted file mode 100644 index bfe24c5..0000000 --- a/src/common/Model/CreateCategory.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.CreateCategory - ( CreateCategory(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -data CreateCategory = CreateCategory - { _createCategory_name :: Text - , _createCategory_color :: Text - } deriving (Show, Generic) - -instance FromJSON CreateCategory diff --git a/src/common/Model/CreateIncome.hs b/src/common/Model/CreateIncome.hs deleted file mode 100644 index 4ee3a50..0000000 --- a/src/common/Model/CreateIncome.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.CreateIncome - ( CreateIncome(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -data CreateIncome = CreateIncome - { _createIncome_date :: Day - , _createIncome_amount :: Int - } deriving (Show, Generic) - -instance FromJSON CreateIncome diff --git a/src/common/Model/CreatePayment.hs b/src/common/Model/CreatePayment.hs deleted file mode 100644 index b5b6256..0000000 --- a/src/common/Model/CreatePayment.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.CreatePayment - ( CreatePayment(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) -import Common.Model.Frequency (Frequency) - -data CreatePayment = CreatePayment - { _createPayment_name :: Text - , _createPayment_cost :: Int - , _createPayment_date :: Day - , _createPayment_category :: CategoryId - , _createPayment_frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON CreatePayment diff --git a/src/common/Model/Currency.hs b/src/common/Model/Currency.hs deleted file mode 100644 index 7c12545..0000000 --- a/src/common/Model/Currency.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Currency - ( Currency(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -newtype Currency = Currency Text deriving (Show, Generic) - -instance FromJSON Currency -instance ToJSON Currency diff --git a/src/common/Model/EditCategory.hs b/src/common/Model/EditCategory.hs deleted file mode 100644 index 2a3a697..0000000 --- a/src/common/Model/EditCategory.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.EditCategory - ( EditCategory(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) - -data EditCategory = EditCategory - { _editCategory_id :: CategoryId - , _editCategory_name :: Text - , _editCategory_color :: Text - } deriving (Show, Generic) - -instance FromJSON EditCategory diff --git a/src/common/Model/EditIncome.hs b/src/common/Model/EditIncome.hs deleted file mode 100644 index a55c39e..0000000 --- a/src/common/Model/EditIncome.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.EditIncome - ( EditIncome(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.Income (IncomeId) - -data EditIncome = EditIncome - { _editIncome_id :: IncomeId - , _editIncome_date :: Day - , _editIncome_amount :: Int - } deriving (Show, Generic) - -instance FromJSON EditIncome diff --git a/src/common/Model/EditPayment.hs b/src/common/Model/EditPayment.hs deleted file mode 100644 index 172c0c1..0000000 --- a/src/common/Model/EditPayment.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.EditPayment - ( EditPayment(..) - ) where - -import Data.Aeson (FromJSON) -import Data.Text (Text) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) -import Common.Model.Frequency (Frequency) -import Common.Model.Payment (PaymentId) - -data EditPayment = EditPayment - { _editPayment_id :: PaymentId - , _editPayment_name :: Text - , _editPayment_cost :: Int - , _editPayment_date :: Day - , _editPayment_category :: CategoryId - , _editPayment_frequency :: Frequency - } deriving (Show, Generic) - -instance FromJSON EditPayment diff --git a/src/common/Model/Frequency.hs b/src/common/Model/Frequency.hs deleted file mode 100644 index 7c46605..0000000 --- a/src/common/Model/Frequency.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Frequency - ( Frequency(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) - -data Frequency = - Punctual - | Monthly - deriving (Eq, Read, Show, Generic) - -instance FromJSON Frequency -instance ToJSON Frequency diff --git a/src/common/Model/Income.hs b/src/common/Model/Income.hs deleted file mode 100644 index 280812f..0000000 --- a/src/common/Model/Income.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Income - ( IncomeId - , Income(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Time (UTCTime) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.User (UserId) - -type IncomeId = Int64 - -data Income = Income - { _income_id :: IncomeId - , _income_userId :: UserId - , _income_date :: Day - , _income_amount :: Int - , _income_createdAt :: UTCTime - , _income_editedAt :: Maybe UTCTime - , _income_deletedAt :: Maybe UTCTime - } deriving (Show, Generic) - -instance FromJSON Income -instance ToJSON Income diff --git a/src/common/Model/Init.hs b/src/common/Model/Init.hs deleted file mode 100644 index 68fcfb8..0000000 --- a/src/common/Model/Init.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Init - ( Init(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) - -import Common.Model.Category (Category) -import Common.Model.Currency (Currency) -import Common.Model.Income (Income) -import Common.Model.Payment (Payment) -import Common.Model.PaymentCategory (PaymentCategory) -import Common.Model.User (UserId, User) - -data Init = Init - { _init_users :: [User] - , _init_currentUser :: UserId - , _init_payments :: [Payment] - , _init_incomes :: [Income] - , _init_categories :: [Category] - , _init_paymentCategories :: [PaymentCategory] - , _init_currency :: Currency - } deriving (Show, Generic) - -instance FromJSON Init -instance ToJSON Init diff --git a/src/common/Model/InitResult.hs b/src/common/Model/InitResult.hs deleted file mode 100644 index 43c16f9..0000000 --- a/src/common/Model/InitResult.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.InitResult - ( InitResult(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -import Common.Model.Init (Init) - -data InitResult = - InitSuccess Init - | InitEmpty (Either Text (Maybe Text)) - deriving (Show, Generic) - -instance FromJSON InitResult -instance ToJSON InitResult diff --git a/src/common/Model/Payment.hs b/src/common/Model/Payment.hs deleted file mode 100644 index 804b501..0000000 --- a/src/common/Model/Payment.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.Payment - ( PaymentId - , Payment(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import Data.Time.Calendar (Day) -import GHC.Generics (Generic) - -import Common.Model.Frequency -import Common.Model.User (UserId) - -type PaymentId = Int64 - -data Payment = Payment - { _payment_id :: PaymentId - , _payment_user :: UserId - , _payment_name :: Text - , _payment_cost :: Int - , _payment_date :: Day - , _payment_frequency :: Frequency - , _payment_createdAt :: UTCTime - , _payment_editedAt :: Maybe UTCTime - , _payment_deletedAt :: Maybe UTCTime - } deriving (Show, Generic) - -instance FromJSON Payment -instance ToJSON Payment diff --git a/src/common/Model/PaymentCategory.hs b/src/common/Model/PaymentCategory.hs deleted file mode 100644 index a0e94f9..0000000 --- a/src/common/Model/PaymentCategory.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.PaymentCategory - ( PaymentCategoryId - , PaymentCategory(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) - -import Common.Model.Category (CategoryId) - -type PaymentCategoryId = Int64 - -data PaymentCategory = PaymentCategory - { _paymentCategory_id :: PaymentCategoryId - , _paymentCategory_name :: Text - , _paymentCategory_category :: CategoryId - , _paymentCategory_createdAt :: UTCTime - , _paymentCategory_editedAt :: Maybe UTCTime - } deriving (Show, Generic) - -instance FromJSON PaymentCategory -instance ToJSON PaymentCategory diff --git a/src/common/Model/SignIn.hs b/src/common/Model/SignIn.hs deleted file mode 100644 index f4da97f..0000000 --- a/src/common/Model/SignIn.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.SignIn - ( SignIn(..) - ) where - -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text) -import GHC.Generics (Generic) - -data SignIn = SignIn - { _signIn_email :: Text - } deriving (Show, Generic) - -instance FromJSON SignIn -instance ToJSON SignIn diff --git a/src/common/Model/User.hs b/src/common/Model/User.hs deleted file mode 100644 index 8c64bc2..0000000 --- a/src/common/Model/User.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Common.Model.User - ( UserId - , User(..) - , find - ) where - -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.List as L -import Data.Int (Int64) -import Data.Text (Text) -import Data.Time (UTCTime) -import GHC.Generics (Generic) - -type UserId = Int64 - -data User = User - { _user_id :: UserId - , _user_creation :: UTCTime - , _user_email :: Text - , _user_name :: Text - } deriving (Show, Generic) - -instance FromJSON User -instance ToJSON User - -find :: UserId -> [User] -> Maybe User -find userId users = L.find ((== userId) . _user_id) users diff --git a/src/common/Util/Text.hs b/src/common/Util/Text.hs deleted file mode 100644 index 4af7a4c..0000000 --- a/src/common/Util/Text.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Common.Util.Text - ( unaccent - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -unaccent :: Text -> Text -unaccent = T.map unaccentChar - -unaccentChar :: Char -> Char -unaccentChar c = case c of - 'à' -> 'a' - 'á' -> 'a' - 'â' -> 'a' - 'ã' -> 'a' - 'ä' -> 'a' - 'ç' -> 'c' - 'è' -> 'e' - 'é' -> 'e' - 'ê' -> 'e' - 'ë' -> 'e' - 'ì' -> 'i' - 'í' -> 'i' - 'î' -> 'i' - 'ï' -> 'i' - 'ñ' -> 'n' - 'ò' -> 'o' - 'ó' -> 'o' - 'ô' -> 'o' - 'õ' -> 'o' - 'ö' -> 'o' - 'š' -> 's' - 'ù' -> 'u' - 'ú' -> 'u' - 'û' -> 'u' - 'ü' -> 'u' - 'ý' -> 'y' - 'ÿ' -> 'y' - 'ž' -> 'z' - _ -> c diff --git a/src/common/View/Format.hs b/src/common/View/Format.hs deleted file mode 100644 index a7fa4e3..0000000 --- a/src/common/View/Format.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Common.View.Format - ( shortDay - , longDay - , price - , number - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import Data.List (intersperse) -import Data.Maybe (fromMaybe) -import Data.Time.Calendar (Day, toGregorian) - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model.Currency (Currency(..)) - -shortDay :: Day -> Text -shortDay date = - Message.get $ Key.Date_Short - day - month - (fromIntegral year) - where (year, month, day) = toGregorian date - -longDay :: Day -> Text -longDay date = - Message.get $ Key.Date_Long - day - (fromMaybe "−" . fmap Message.get . monthToKey $ month) - (fromIntegral year) - where (year, month, day) = toGregorian date - - monthToKey 1 = Just Key.Month_January - monthToKey 2 = Just Key.Month_February - monthToKey 3 = Just Key.Month_March - monthToKey 4 = Just Key.Month_April - monthToKey 5 = Just Key.Month_May - monthToKey 6 = Just Key.Month_June - monthToKey 7 = Just Key.Month_July - monthToKey 8 = Just Key.Month_August - monthToKey 9 = Just Key.Month_September - monthToKey 10 = Just Key.Month_October - monthToKey 11 = Just Key.Month_November - monthToKey 12 = Just Key.Month_December - monthToKey _ = Nothing - -price :: Currency -> Int -> Text -price (Currency currency) amount = T.concat [ number amount, " ", currency ] - -number :: Int -> Text -number n = - T.pack - . (++) (if n < 0 then "-" else "") - . reverse - . concat - . intersperse " " - . group 3 - . reverse - . show - . abs $ n - -group :: Int -> [a] -> [[a]] -group n xs = - if length xs <= n - then [xs] - else (take n xs) : (group n (drop n xs)) diff --git a/src/migrations/1.sql b/src/migrations/1.sql deleted file mode 100644 index d7c300e..0000000 --- a/src/migrations/1.sql +++ /dev/null @@ -1,65 +0,0 @@ -CREATE TABLE IF NOT EXISTS "user" ( - "id" INTEGER PRIMARY KEY, - "creation" TIMESTAMP NOT NULL, - "email" VARCHAR NOT NULL, - "name" VARCHAR NOT NULL, - CONSTRAINT "uniq_user_email" UNIQUE ("email"), - CONSTRAINT "uniq_user_name" UNIQUE ("name") -); - -CREATE TABLE IF NOT EXISTS "job" ( - "id" INTEGER PRIMARY KEY, - "kind" VARCHAR NOT NULL, - "last_execution" TIMESTAMP NULL, - "last_check" TIMESTAMP NULL, - CONSTRAINT "uniq_job_kind" UNIQUE ("kind") -); - -CREATE TABLE IF NOT EXISTS "sign_in"( - "id" INTEGER PRIMARY KEY, - "token" VARCHAR NOT NULL, - "creation" TIMESTAMP NOT NULL, - "email" VARCHAR NOT NULL, - "is_used" BOOLEAN NOT NULL, - CONSTRAINT "uniq_sign_in_token" UNIQUE ("token") -); - -CREATE TABLE IF NOT EXISTS "payment"( - "id" INTEGER PRIMARY KEY, - "user_id" INTEGER NOT NULL REFERENCES "user", - "name" VARCHAR NOT NULL, - "cost" INTEGER NOT NULL, - "date" DATE NOT NULL, - "frequency" VARCHAR NOT NULL, - "created_at" TIMESTAMP NOT NULL, - "edited_at" TIMESTAMP NULL, - "deleted_at" TIMESTAMP NULL -); - -CREATE TABLE IF NOT EXISTS "income"( - "id" INTEGER PRIMARY KEY, - "user_id" INTEGER NOT NULL REFERENCES "user", - "date" DATE NOT NULL, - "amount" INTEGERNOT NULL, - "created_at" TIMESTAMP NOT NULL, - "edited_at" TIMESTAMP NULL, - "deleted_at" TIMESTAMP NULL -); - -CREATE TABLE IF NOT EXISTS "category"( - "id" INTEGER PRIMARY KEY, - "name" VARCHAR NOT NULL, - "color" VARCHAR NOT NULL, - "created_at" TIMESTAMP NOT NULL, - "edited_at" TIMESTAMP NULL, - "deleted_at" TIMESTAMP NULL -); - -CREATE TABLE IF NOT EXISTS "payment_category"( - "id" INTEGER PRIMARY KEY, - "name" VARCHAR NOT NULL, - "category" INTEGER NOT NULL REFERENCES "category", - "created_at" TIMESTAMP NOT NULL, - "edited_at" TIMESTAMP NULL, - CONSTRAINT "uniq_payment_category_name" UNIQUE ("name") -); diff --git a/src/migrations/2.sql b/src/migrations/2.sql deleted file mode 100644 index ec0d1b0..0000000 --- a/src/migrations/2.sql +++ /dev/null @@ -1,23 +0,0 @@ -BEGIN TRANSACTION; - -ALTER TABLE payment RENAME TO tmp_payment; - -CREATE TABLE IF NOT EXISTS "payment"( - "id" INTEGER PRIMARY KEY, - "user" INTEGER NOT NULL REFERENCES "user", - "name" VARCHAR NOT NULL, - "cost" INTEGER NOT NULL, - "date" DATE NOT NULL, - "frequency" VARCHAR NOT NULL, - "created_at" TIMESTAMP NOT NULL, - "edited_at" TIMESTAMP NULL, - "deleted_at" TIMESTAMP NULL -); - -INSERT INTO payment(id, user, name, cost, date, frequency, created_at, edited_at, deleted_at) -SELECT id, user_id, name, cost, date, frequency, created_at, edited_at, deleted_at -FROM tmp_payment; - -DROP TABLE tmp_payment; - -COMMIT; diff --git a/src/server/Common b/src/server/Common deleted file mode 120000 index 60d3b0a..0000000 --- a/src/server/Common +++ /dev/null @@ -1 +0,0 @@ -../common
\ No newline at end of file diff --git a/src/server/Conf.hs b/src/server/Conf.hs deleted file mode 100644 index 92df4e9..0000000 --- a/src/server/Conf.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Conf - ( get - , Conf(..) - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.ConfigManager as Conf -import Data.Time.Clock (NominalDiffTime) - -import Common.Model.Currency (Currency(..)) - -data Conf = Conf - { hostname :: Text - , port :: Int - , signInExpiration :: NominalDiffTime - , currency :: Currency - , noReplyMail :: Text - , https :: Bool - } deriving Show - -get :: FilePath -> IO Conf -get path = do - conf <- - (flip fmap) (Conf.readConfig path) (\configOrError -> do - conf <- configOrError - Conf <$> - Conf.lookup "hostname" conf <*> - Conf.lookup "port" conf <*> - Conf.lookup "signInExpiration" conf <*> - fmap Currency (Conf.lookup "currency" conf) <*> - Conf.lookup "noReplyMail" conf <*> - Conf.lookup "https" conf - ) - case conf of - Left msg -> error (T.unpack msg) - Right c -> return c diff --git a/src/server/Controller/Category.hs b/src/server/Controller/Category.hs deleted file mode 100644 index 1a44083..0000000 --- a/src/server/Controller/Category.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.Category - ( create - , edit - , delete - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -import Web.Scotty hiding (delete) - -import Common.Model.Category (CategoryId) -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import qualified Common.Model.CreateCategory as Json -import qualified Common.Model.EditCategory as Json - -import Json (jsonId) -import qualified Model.Category as Category -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 . Query.run $ Category.create name color) >>= jsonId - ) - -edit :: Json.EditCategory -> ActionM () -edit (Json.EditCategory categoryId name color) = - Secure.loggedAction (\_ -> do - updated <- liftIO . Query.run $ Category.edit categoryId name color - if updated - then status ok200 - else status badRequest400 - ) - -delete :: CategoryId -> ActionM () -delete categoryId = - Secure.loggedAction (\_ -> do - deleted <- liftIO . Query.run $ do - paymentCategories <- PaymentCategory.listByCategory categoryId - if null paymentCategories - then Category.delete categoryId - else return False - if deleted - then - status ok200 - else do - status badRequest400 - text . TL.fromStrict $ Message.get Key.Category_NotDeleted - ) diff --git a/src/server/Controller/Income.hs b/src/server/Controller/Income.hs deleted file mode 100644 index 148b713..0000000 --- a/src/server/Controller/Income.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.Income - ( create - , editOwn - , deleteOwn - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text.Lazy as TL -import Web.Scotty - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (CreateIncome(..), EditIncome(..), IncomeId, User(..)) - -import Json (jsonId) -import qualified Model.Income as Income -import qualified Model.Query as Query -import qualified Secure - -create :: CreateIncome -> ActionM () -create (CreateIncome date amount) = - Secure.loggedAction (\user -> - (liftIO . Query.run $ Income.create (_user_id user) date amount) >>= jsonId - ) - -editOwn :: EditIncome -> ActionM () -editOwn (EditIncome incomeId date amount) = - Secure.loggedAction (\user -> do - updated <- liftIO . Query.run $ Income.editOwn (_user_id user) incomeId date amount - if updated - then status ok200 - else status badRequest400 - ) - -deleteOwn :: IncomeId -> ActionM () -deleteOwn incomeId = - Secure.loggedAction (\user -> do - deleted <- liftIO . Query.run $ Income.deleteOwn user incomeId - if deleted - then - status ok200 - else do - status badRequest400 - text . TL.fromStrict $ Message.get Key.Income_NotDeleted - ) diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs deleted file mode 100644 index 8473c5c..0000000 --- a/src/server/Controller/Index.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Controller.Index - ( get - , signOut - ) where - -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Time.Clock (getCurrentTime, diffUTCTime) -import Network.HTTP.Types.Status (ok200) -import Prelude hiding (error) -import Web.Scotty hiding (get) - -import qualified Common.Message as Message -import Common.Message.Key (Key) -import qualified Common.Message.Key as Key -import Common.Model (InitResult(..), User(..)) - -import Conf (Conf(..)) -import Model.Init (getInit) -import qualified LoginSession -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 () -get conf mbToken = do - initResult <- case mbToken of - Just token -> do - userOrError <- validateSignIn conf token - case userOrError of - Left errorKey -> - return . InitEmpty . Left . Message.get $ errorKey - Right user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - Nothing -> do - mbLoggedUser <- getLoggedUser - case mbLoggedUser of - Nothing -> - return . InitEmpty . Right $ Nothing - Just user -> - liftIO . Query.run . fmap InitSuccess $ getInit user conf - html $ page initResult - -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 . Query.run $ SignIn.getSignIn textToken - now <- liftIO getCurrentTime - case mbSignIn of - Nothing -> - return . Left $ Key.SignIn_LinkInvalid - Just signIn -> - if SignIn.isUsed signIn - then - return . Left $ Key.SignIn_LinkUsed - else - let diffTime = now `diffUTCTime` (SignIn.creation signIn) - in if diffTime > signInExpiration conf - then - return . Left $ Key.SignIn_LinkExpired - else do - LoginSession.put conf (SignIn.token signIn) - mbUser <- liftIO . Query.run $ do - SignIn.signInTokenToUsed . SignIn.id $ signIn - User.get . SignIn.email $ signIn - return $ case mbUser of - Nothing -> Left Key.Secure_Unauthorized - Just user -> Right user - -getLoggedUser :: ActionM (Maybe User) -getLoggedUser = do - mbToken <- LoginSession.get - case mbToken of - Nothing -> - return Nothing - Just token -> do - 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 deleted file mode 100644 index 6a9ede7..0000000 --- a/src/server/Controller/Payment.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.Payment - ( list - , create - , editOwn - , deleteOwn - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import Web.Scotty - -import qualified Common.Model.CreatePayment as M -import qualified Common.Model.EditPayment as M -import Common.Model (PaymentId, User(..)) - -import Json (jsonId) -import qualified Model.Payment as Payment -import qualified Model.PaymentCategory as PaymentCategory -import qualified Model.Query as Query -import qualified Secure - -list :: ActionM () -list = - Secure.loggedAction (\_ -> - (liftIO . Query.run $ Payment.list) >>= json - ) - -create :: M.CreatePayment -> ActionM () -create (M.CreatePayment name cost date category frequency) = - Secure.loggedAction (\user -> - (liftIO . Query.run $ do - PaymentCategory.save name category - Payment.create (_user_id user) name cost date frequency - ) >>= jsonId - ) - -editOwn :: M.EditPayment -> ActionM () -editOwn (M.EditPayment paymentId name cost date category frequency) = - Secure.loggedAction (\user -> do - 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 () - return edited - if updated - then status ok200 - else status badRequest400 - ) - -deleteOwn :: PaymentId -> ActionM () -deleteOwn paymentId = - Secure.loggedAction (\user -> do - 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 deleted file mode 100644 index 932ce53..0000000 --- a/src/server/Controller/SignIn.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Controller.SignIn - ( signIn - ) where - -import Control.Monad.IO.Class (liftIO) -import Network.HTTP.Types.Status (ok200, badRequest400) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import Web.Scotty - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import qualified Common.Model.SignIn as M - -import Conf (Conf) -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 -> M.SignIn -> ActionM () -signIn conf (M.SignIn email) = - if Email.isValid (TE.encodeUtf8 email) - then do - maybeUser <- liftIO . Query.run $ User.get email - case maybeUser of - Just user -> do - token <- liftIO . Query.run $ SignIn.createSignInToken email - let url = T.concat [ - if Conf.https conf then "https://" else "http://", - Conf.hostname conf, - "?signInToken=", - token - ] - maybeSentMail <- liftIO . SendMail.sendMail $ SignIn.mail conf user url [email] - case maybeSentMail of - Right _ -> textKey ok200 Key.SignIn_EmailSent - Left _ -> textKey badRequest400 Key.SignIn_EmailSendFail - Nothing -> textKey badRequest400 Key.Secure_Unauthorized - else textKey badRequest400 Key.SignIn_EmailInvalid - where textKey st key = status st >> (text . TL.fromStrict $ Message.get key) diff --git a/src/server/Cookie.hs b/src/server/Cookie.hs deleted file mode 100644 index 96d45da..0000000 --- a/src/server/Cookie.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Cookie - ( makeSimpleCookie - , setCookie - , setSimpleCookie - , getCookie - , getCookies - , deleteCookie - ) where - -import Control.Monad ( liftM ) - -import qualified Data.Text as TS -import qualified Data.Text.Encoding as TS -import qualified Data.Text.Lazy.Encoding as TL - -import Conf (Conf) -import qualified Conf - -import qualified Data.Map as Map - -import qualified Data.ByteString.Lazy as BSL - -import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) - -import Blaze.ByteString.Builder ( toLazyByteString ) - -import Web.Scotty.Trans -import Web.Cookie - -makeSimpleCookie :: Conf -> TS.Text -> TS.Text -> SetCookie -makeSimpleCookie conf name value = - def - { setCookieName = TS.encodeUtf8 name - , setCookieValue = TS.encodeUtf8 value - , setCookiePath = Just $ TS.encodeUtf8 "/" - , setCookieSecure = Conf.https conf - } - -setCookie :: (Monad m) => SetCookie -> ActionT e m () -setCookie name = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie name) - -setSimpleCookie :: (Monad m) => Conf -> TS.Text -> TS.Text -> ActionT e m () -setSimpleCookie conf name value = setCookie $ makeSimpleCookie conf name value - -getCookie :: (Monad m, ScottyError e) => TS.Text -> ActionT e m (Maybe TS.Text) -getCookie name = liftM (Map.lookup name) getCookies - -getCookies :: (Monad m, ScottyError e) => ActionT e m (Map.Map TS.Text TS.Text) -getCookies = - liftM (Map.fromList . maybe [] parse) $ header "Cookie" - where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8 - -deleteCookie :: (Monad m) => Conf -> TS.Text -> ActionT e m () -deleteCookie conf name = setCookie $ (makeSimpleCookie conf name "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 } diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs deleted file mode 100644 index 06c468e..0000000 --- a/src/server/Design/Color.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Design.Color where - -import qualified Clay.Color as C - --- http://chir.ag/projects/name-that-color/#969696 - -white :: C.Color -white = C.white - -black :: C.Color -black = C.black - -chestnutRose :: C.Color -chestnutRose = C.rgb 207 92 86 - -unknown :: C.Color -unknown = C.rgb 86 92 207 - -mossGreen :: C.Color -mossGreen = C.rgb 159 210 165 - -gothic :: C.Color -gothic = C.rgb 108 162 164 - -negroni :: C.Color -negroni = C.rgb 255 223 196 - -wildSand :: C.Color -wildSand = C.rgb 245 245 245 - -silver :: C.Color -silver = C.rgb 200 200 200 - -dustyGray :: C.Color -dustyGray = C.rgb 150 150 150 diff --git a/src/server/Design/Constants.hs b/src/server/Design/Constants.hs deleted file mode 100644 index 4e2b8cc..0000000 --- a/src/server/Design/Constants.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Design.Constants where - -import Clay - -iconFontSize :: Size LengthUnit -iconFontSize = px 32 - -radius :: Size LengthUnit -radius = px 3 - -blockPadding :: Size LengthUnit -blockPadding = px 15 - -blockPercentWidth :: Double -blockPercentWidth = 90 - -blockPercentMargin :: Double -blockPercentMargin = (100 - blockPercentWidth) / 2 - -inputHeight :: Double -inputHeight = 40 - -focusLighten :: Color -> Color -focusLighten baseColor = baseColor +. 20 - -focusDarken :: Color -> Color -focusDarken baseColor = baseColor -. 20 diff --git a/src/server/Design/Dialog.hs b/src/server/Design/Dialog.hs deleted file mode 100644 index 4678633..0000000 --- a/src/server/Design/Dialog.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Dialog - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -design :: Css -design = do - - ".content" ? do - minWidth (px 270) - - ".paymentDialog" & do - ".radioGroup" ? ".title" ? display none - ".selectInput" ? do - select ? width (pct 100) - marginBottom (em 1) - - ".deletePaymentDialog" <> ".deleteIncomeDialog" ? do - h1 ? marginBottom (em 1.5) diff --git a/src/server/Design/Errors.hs b/src/server/Design/Errors.hs deleted file mode 100644 index 57aaeee..0000000 --- a/src/server/Design/Errors.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Errors - ( design - ) where - -import Clay - -import Design.Color as Color - -design :: Css -design = do - position fixed - top (px 20) - left (pct 50) - "transform" -: "translateX(-50%)" - margin (px 0) (px 0) (px 0) (px 0) - disapearKeyframes - - ".error" ? do - disapearAnimation - let errorColor = Color.chestnutRose -. 15 - color errorColor - border solid (px 2) errorColor - backgroundColor Color.white - borderRadius (px 5) (px 5) (px 5) (px 5) - padding (px 5) (px 5) (px 5) (px 5) - - before & display none - -disapearAnimation :: Css -disapearAnimation = do - animationName "disapear" - animationDelay (sec 5) - animationDuration (sec 1) - animationFillMode forwards - -disapearKeyframes :: Css -disapearKeyframes = keyframes - "disapear" - [ ( 10 - , do - opacity 0 - height (px 40) - lineHeight (px 40) - marginBottom (px 10) - ) - , ( 100 - , do - opacity 0 - height (px 0) - lineHeight (px 0) - marginBottom (px 0) - ) - ] diff --git a/src/server/Design/Form.hs b/src/server/Design/Form.hs deleted file mode 100644 index ebb8ac8..0000000 --- a/src/server/Design/Form.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Form - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Color as Color - -design :: Css -design = do - - let inputHeight = 30 - let inputTop = 22 - let inputPaddingBottom = 3 - let inputZIndex = 1 - - label ? do - cursor pointer - color Color.silver - - ".textInput" ? do - position relative - marginBottom (em 1.5) - paddingTop (px inputTop) - marginTop (px (-10)) - - input ? do - width (pct 100) - position relative - zIndex inputZIndex - backgroundColor transparent - paddingBottom (px inputPaddingBottom) - borderStyle none - borderBottom solid (px 1) Color.dustyGray - marginBottom (px 5) - height (px inputHeight) - lineHeight (px inputHeight) - focus & do - borderWidth (px 2) - paddingBottom (px $ inputPaddingBottom - 1) - - label ? do - lineHeight (px inputHeight) - position absolute - top (px inputTop) - left (px 0) - transition "all" (sec 0.2) easeIn (sec 0) - - button ? do - position absolute - right (px 0) - top (px 27) - zIndex inputZIndex - hover & "svg path" ? do - "fill" -: "rgb(220, 220, 220)" - - (input # ".filled" |+ label) <> (input # focus |+ label) ? do - top (px 0) - fontSize (pct 80) - - ".error" & do - input ? do - borderBottomColor Color.chestnutRose - - ".errorMessage" ? do - position absolute - color Color.chestnutRose - fontSize (pct 80) - - ".colorInput" ? do - display flex - alignItems center - marginBottom (em 1.5) - - input ? do - borderColor transparent - backgroundColor transparent - - ".radioGroup" ? do - position relative - marginBottom (em 2) - - ".title" ? do - color Color.silver - marginBottom (em 0.8) - - ".radioInputs" ? do - display flex - "justify-content" -: "center" - - ".radioInput:not(:last-child)::after" ? do - content (stringContent "/") - marginLeft (px 10) - marginRight (px 10) - - input ? do - opacity 0 - width (px 30) - margin (px 0) (px (-15)) (px 0) (px (-15)) - - "input:focus + label" ? do - textDecoration underline - - "input:checked + label" ? do - color Color.chestnutRose - fontWeight bold - - ".selectInput" ? do - label ? do - display block - marginBottom (px 10) - fontSize (pct 80) - select ? do - backgroundColor Color.white - border solid (px 1) Color.silver - sym borderRadius (px 3) - sym2 padding (px 5) (px 8) - option ? do - firstChild & display none - sym2 padding (px 5) (px 8) - ".error" & do - select ? borderColor Color.chestnutRose - ".errorMessage" ? do - color Color.chestnutRose - fontSize (pct 80) - marginTop (em 0.5) diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs deleted file mode 100644 index 47ea4a9..0000000 --- a/src/server/Design/Global.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Global - ( globalDesign - ) where - -import Clay - -import Data.Text.Lazy (Text) - -import qualified Design.Views as Views -import qualified Design.Form as Form -import qualified Design.Errors as Errors -import qualified Design.Dialog as Dialog -import qualified Design.Tooltip as Tooltip - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -globalDesign :: Text -globalDesign = renderWith compact [] global - -global :: Css -global = do - ".errors" ? Errors.design - ".dialog" ? Dialog.design - ".tooltip" ? Tooltip.design - Views.design - Form.design - - body ? do - minWidth (px 320) - fontFamily ["Cantarell"] [sansSerif] - Media.tablet $ do - fontSize (px 15) - button ? fontSize (px 15) - input ? fontSize (px 15) - Media.mobile $ do - fontSize (px 14) - button ? fontSize (px 14) - input ? fontSize (px 14) - - a ? cursor pointer - - input ? fontSize inherit - - h1 ? do - color Color.chestnutRose - marginBottom (em 1) - lineHeight (em 1.2) - - Media.desktop $ fontSize (px 24) - Media.tablet $ fontSize (px 22) - Media.mobile $ fontSize (px 20) - - ul ? do - "margin-bottom" -: "3vh" - "margin-left" -: "1vh" - li <? do - "margin-bottom" -: "2vh" - before & do - content (stringContent "• ") - color Color.chestnutRose - "margin-right" -: "0.3vw" - ul <? do - "margin-left" -: "3vh" - "margin-top" -: "2vh" - - ".dialog" ? ".content" ? button ? do - ".confirm" & Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - ".undo" & Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten - - svg ? height (pct 100) diff --git a/src/server/Design/Helper.hs b/src/server/Design/Helper.hs deleted file mode 100644 index 41528ed..0000000 --- a/src/server/Design/Helper.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Helper - ( clearFix - , button - , waitable - , input - , centeredWithMargin - , verticalCentering - ) where - -import Prelude hiding (span) - -import Clay hiding (button, input) - -import Design.Constants -import Design.Color as Color - -clearFix :: Css -clearFix = - after & do - content (stringContent "") - display displayTable - clear both - -button :: Color -> Color -> Size a -> (Color -> Color) -> Css -button backgroundCol textCol h focusOp = do - display flex - alignItems center - justifyContent center - backgroundColor backgroundCol - padding (px 0) (px 10) (px 0) (px 10) - color textCol - borderRadius radius radius radius radius - verticalAlign middle - cursor pointer - lineHeight h - height h - textAlign (alignSide sideCenter) - hover & backgroundColor (focusOp backgroundCol) - focus & backgroundColor (focusOp backgroundCol) - waitable - -waitable :: Css -waitable = do - svg # ".loader" ? display none - ".waiting" & do - ".content" ? do - display flex - fontSize (px 0) - opacity 0 - svg # ".loader" ? do - display block - rotateKeyframes - rotateAnimation - -input :: Double -> Css -input h = do - height (px h) - padding (px 10) (px 10) (px 10) (px 10) - borderRadius radius radius radius radius - border solid (px 1) Color.dustyGray - focus & borderColor Color.silver - verticalAlign middle - -centeredWithMargin :: Css -centeredWithMargin = do - width (pct blockPercentWidth) - marginLeft auto - marginRight auto - -verticalCentering :: Css -verticalCentering = do - position absolute - top (pct 50) - "transform" -: "translateY(-50%)" - -rotateAnimation :: Css -rotateAnimation = do - animationName "rotate" - animationDuration (sec 1) - animationTimingFunction easeOut - animationIterationCount infinite - -rotateKeyframes :: Css -rotateKeyframes = keyframes - "rotate" - [ (0, "transform" -: "rotate(0deg)") - , (100, "transform" -: "rotate(360deg)") - ] diff --git a/src/server/Design/Media.hs b/src/server/Design/Media.hs deleted file mode 100644 index 77220ee..0000000 --- a/src/server/Design/Media.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Design.Media - ( mobile - , mobileTablet - , tablet - , tabletDesktop - , desktop - ) where - -import Clay hiding (query) -import qualified Clay -import Clay.Stylesheet (Feature) -import qualified Clay.Media as Media - -mobile :: Css -> Css -mobile = query [Media.maxWidth mobileTabletLimit] - -mobileTablet :: Css -> Css -mobileTablet = query [Media.maxWidth tabletDesktopLimit] - -tablet :: Css -> Css -tablet = query [Media.minWidth mobileTabletLimit, Media.maxWidth tabletDesktopLimit] - -tabletDesktop :: Css -> Css -tabletDesktop = query [Media.minWidth mobileTabletLimit] - -desktop :: Css -> Css -desktop = query [Media.minWidth tabletDesktopLimit] - -query :: [Feature] -> Css -> Css -query = Clay.query Media.screen - -mobileTabletLimit :: Size LengthUnit -mobileTabletLimit = (px 520) - -tabletDesktopLimit :: Size LengthUnit -tabletDesktopLimit = (px 950) diff --git a/src/server/Design/Tooltip.hs b/src/server/Design/Tooltip.hs deleted file mode 100644 index 1da8764..0000000 --- a/src/server/Design/Tooltip.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Tooltip - ( design - ) where - -import Clay - -import Design.Color as Color - -design :: Css -design = do - backgroundColor Color.mossGreen - borderRadius (px 5) (px 5) (px 5) (px 5) - padding (px 5) (px 5) (px 5) (px 5) - color Color.white diff --git a/src/server/Design/View/Header.hs b/src/server/Design/View/Header.hs deleted file mode 100644 index 20627e6..0000000 --- a/src/server/Design/View/Header.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Header - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Media as Media - -design :: Css -design = do - let headerPadding = "padding" -: "0 20px" - display flex - "flex-wrap" -: "wrap" - lineHeightMedia - position relative - backgroundColor Color.chestnutRose - color Color.white - Media.desktop $ marginBottom (em 3) - Media.mobileTablet $ marginBottom (em 2) - Media.mobile $ marginBottom (em 1.5) - - ".title" <> ".item" ? headerPadding - - ".title" ? do - height (pct 100) - textAlign (alignSide sideLeft) - - Media.mobile $ fontSize (px 22) - Media.mobileTablet $ width (pct 100) - Media.tabletDesktop $ do - display inlineBlock - fontSize (px 35) - - ".item" ? do - display inlineBlock - transition "background-color" (ms 50) easeIn (sec 0) - ".current" & backgroundColor (Color.chestnutRose -. 20) - Media.mobile $ fontSize (px 13) - - (".item" # hover) <> (".item" # focus) ? backgroundColor (Color.chestnutRose +. 10) - (".item.current" # hover) <> (".item.current" # focus) ? backgroundColor (Color.chestnutRose -. 10) - - ".nameSignOut" ? do - display flex - heightMedia - position absolute - top (px 0) - right (px 0) - - ".name" ? do - Media.mobile $ display none - Media.tabletDesktop $ headerPadding - - ".signOut" ? do - Helper.waitable - heightMedia - svg ? do - Media.tabletDesktop $ width (px 30) - Media.mobile $ width (px 20) - "path" ? ("fill" -: "white") - -lineHeightMedia :: Css -lineHeightMedia = do - Media.desktop $ lineHeight (px 80) - Media.tablet $ lineHeight (px 65) - Media.mobile $ lineHeight (px 50) - -heightMedia :: Css -heightMedia = do - Media.desktop $ height (px 80) - Media.tablet $ height (px 65) - Media.mobile $ height (px 50) diff --git a/src/server/Design/View/Payment.hs b/src/server/Design/View/Payment.hs deleted file mode 100644 index d3c7650..0000000 --- a/src/server/Design/View/Payment.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment - ( design - ) where - -import Clay - -import qualified Design.View.Payment.Header as Header -import qualified Design.View.Payment.Table as Table -import qualified Design.View.Payment.Pages as Pages - -design :: Css -design = do - ".header" ? Header.design - ".table" ? Table.design - ".pages" ? Pages.design diff --git a/src/server/Design/View/Payment/Header.hs b/src/server/Design/View/Payment/Header.hs deleted file mode 100644 index f02da8a..0000000 --- a/src/server/Design/View/Payment/Header.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment.Header - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Constants - -import qualified Design.Helper as Helper -import qualified Design.Color as Color -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - Media.desktop $ marginBottom (em 3) - Media.mobileTablet $ marginBottom (em 2) - marginLeft (pct blockPercentMargin) - marginRight (pct blockPercentMargin) - - ".payerAndAdd" ? do - Media.tabletDesktop $ display flex - marginBottom (em 1) - - ".exceedingPayers" ? do - backgroundColor Color.mossGreen - borderRadius (px 5) (px 5) (px 5) (px 5) - color Color.white - lineHeight (px Constants.inputHeight) - paddingLeft (px 10) - paddingRight (px 10) - - Media.tabletDesktop $ do - "flex-grow" -: "1" - marginRight (px 15) - - Media.mobile $ do - marginBottom (em 1) - textAlign (alignSide sideCenter) - - ".exceedingPayer:not(:last-child)::after" ? content (stringContent ", ") - - ".userName" ? marginRight (px 8) - - ".addPayment" ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.mobile $ width (pct 100) - - ".searchLine" ? do - marginBottom (em 1) - form ? do - Media.mobile $ textAlign (alignSide sideCenter) - - ".textInput" ? do - display inlineBlock - marginBottom (px 0) - - Media.tabletDesktop $ marginRight (px 30) - Media.mobile $ do - marginBottom (em 1) - width (pct 100) - - ".radioGroup" ? do - display inlineBlock - marginBottom (px 0) - ".title" ? display none - - ".infos" ? do - Media.tabletDesktop $ lineHeight (px Constants.inputHeight) - Media.mobile $ lineHeight (px 25) - - ".total" <> ".partition" ? do - Media.mobileTablet $ display block - Media.mobile $ do - fontSize (pct 90) - textAlign (alignSide sideCenter) - - ".partition" ? do - color Color.dustyGray - Media.desktop $ marginLeft (px 15) diff --git a/src/server/Design/View/Payment/Pages.hs b/src/server/Design/View/Payment/Pages.hs deleted file mode 100644 index ade81a8..0000000 --- a/src/server/Design/View/Payment/Pages.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment.Pages - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Media as Media - -design :: Css -design = do - textAlign (alignSide sideCenter) - Helper.clearFix - - Media.desktop $ do - padding (px 40) (px 30) (px 30) (px 30) - - Media.tablet $ do - padding (px 30) (px 30) (px 30) (px 30) - - Media.mobile $ do - padding (px 20) (px 0) (px 20) (px 0) - lineHeight (px 40) - - ".page" ? do - display inlineBlock - fontWeight bold - - Media.desktop $ do - Helper.button Color.white Color.dustyGray (px 50) Constants.focusDarken - - Media.tabletDesktop $ do - border solid (px 2) Color.dustyGray - marginRight (px 10) - - Media.tablet $ do - Helper.button Color.white Color.dustyGray (px 40) Constants.focusDarken - fontSize (px 15) - - Media.mobile $ do - Helper.button Color.white Color.dustyGray (px 30) Constants.focusDarken - fontSize (px 12) - border solid (px 1) Color.dustyGray - marginRight (px 5) - - ":not(.current)" & cursor pointer - - ".current" & do - borderColor Color.chestnutRose - color Color.chestnutRose diff --git a/src/server/Design/View/Payment/Table.hs b/src/server/Design/View/Payment/Table.hs deleted file mode 100644 index a866b40..0000000 --- a/src/server/Design/View/Payment/Table.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Payment.Table - ( design - ) where - -import Clay - -import qualified Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - ".cell" ? do - ".name" & do - Media.tabletDesktop $ width (pct 30) - - ".cost" & do - Media.tabletDesktop $ width (pct 10) - - ".user" & do - Media.tabletDesktop $ width (pct 15) - - ".category" & do - Media.tabletDesktop $ width (pct 10) - - ".date" & do - Media.tabletDesktop $ width (pct 15) - Media.desktop $ do - ".shortDate" ? display none - ".longDate" ? display inline - Media.tablet $ do - ".shortDate" ? display inline - ".longDate" ? display none - Media.mobile $ do - ".shortDate" ? display none - ".longDate" ? display inline - marginBottom (em 0.5) - - ".button" & svg ? do - "path" ? ("fill" -: (plain . unValue . value $ Color.chestnutRose)) - width (px 18) diff --git a/src/server/Design/View/SignIn.hs b/src/server/Design/View/SignIn.hs deleted file mode 100644 index 214e663..0000000 --- a/src/server/Design/View/SignIn.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.SignIn - ( design - ) where - -import Clay -import Data.Monoid ((<>)) - -import qualified Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants - -design :: Css -design = do - let inputHeight = 50 - width (px 500) - marginTop (px 100) - marginLeft auto - marginRight auto - - input ? do - Helper.input inputHeight - display block - width (pct 100) - marginBottom (px 10) - - button ? do - Helper.button Color.gothic Color.white (px inputHeight) Constants.focusLighten - display flex - alignItems center - justifyContent center - width (pct 100) - fontSize (em 1.2) - svg ? "path" ? ("fill" -: "white") - - ".success" <> ".error" ? do - marginTop (px 40) - textAlign (alignSide sideCenter) - - ".success" ? color Color.mossGreen - ".error" ? color Color.chestnutRose diff --git a/src/server/Design/View/Stat.hs b/src/server/Design/View/Stat.hs deleted file mode 100644 index 0a5b258..0000000 --- a/src/server/Design/View/Stat.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Stat - ( design - ) where - -import Clay - -design :: Css -design = do - h1 ? paddingBottom (px 0) - - ".exceedingPayers" ? ".userName" ? marginRight (px 5) - - ".mean" ? marginBottom (em 1.5) diff --git a/src/server/Design/View/Table.hs b/src/server/Design/View/Table.hs deleted file mode 100644 index 95abf90..0000000 --- a/src/server/Design/View/Table.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.View.Table - ( design - ) where - -import Data.Monoid ((<>)) - -import Clay - -import Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - ".emptyTableMsg" ? do - margin (em 2) (em 2) (em 2) (em 2) - textAlign (alignSide sideCenter) - - ".lines" ? do - Media.tabletDesktop $ display displayTable - width (pct 100) - textAlign (alignSide (sideCenter)) - - ".header" <> ".row" ? do - Media.tabletDesktop $ display tableRow - - ".header" ? do - Media.desktop $ do - fontSize (px 18) - height (px 70) - - Media.tabletDesktop $ do - backgroundColor Color.gothic - color Color.white - - Media.tablet $ do - fontSize (px 16) - height (px 60) - - Media.mobile $ do - display none - - ".row" ? do - nthChild "even" & backgroundColor Color.wildSand - - Media.desktop $ do - fontSize (px 18) - height (px 60) - - Media.tablet $ do - height (px 50) - - Media.mobile $ do - lineHeight (px 25) - paddingTop (px 10) - paddingBottom (px 10) - - ".cell" ? do - Media.tabletDesktop $ display tableCell - position relative - verticalAlign middle - - firstChild & do - Media.mobile $ do - fontSize (px 20) - lineHeight (px 30) - color Color.gothic - - ".refund" & color Color.mossGreen - - ".cell.button" & do - position relative - textAlign (alignSide sideCenter) - button ? do - padding (px 10) (px 10) (px 10) (px 10) - hover & "svg path" ? do - "fill" -: "rgb(237, 122, 116)" - - Media.tabletDesktop $ width (pct 3) - - Media.mobile $ do - display inlineBlock - button ? display flex diff --git a/src/server/Design/Views.hs b/src/server/Design/Views.hs deleted file mode 100644 index bc6ac83..0000000 --- a/src/server/Design/Views.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Design.Views - ( design - ) where - -import Clay - -import qualified Design.View.Header as Header -import qualified Design.View.Payment as Payment -import qualified Design.View.SignIn as SignIn -import qualified Design.View.Stat as Stat -import qualified Design.View.Table as Table - -import qualified Design.Helper as Helper -import qualified Design.Constants as Constants -import qualified Design.Color as Color -import qualified Design.Media as Media - -design :: Css -design = do - header ? Header.design - ".payment" ? Payment.design - ".signIn" ? SignIn.design - ".stat" ? Stat.design - Table.design - - ".withMargin" ? do - "margin" -: "0 2vw" - - ".titleButton" ? do - h1 ? do - Media.tabletDesktop $ float floatLeft - - button ? do - Helper.button Color.chestnutRose Color.white (px Constants.inputHeight) Constants.focusLighten - Media.tabletDesktop $ do - float floatRight - position relative - top (px (-8)) - Media.mobile $ do - width (pct 100) - marginBottom (px 20) - - ".tag" ? do - sym borderRadius (px 4) - sym2 padding (px 2) (px 5) - boxShadow (px 2) (px 2) (px 5) (rgba 0 0 0 0.3) - color Color.white diff --git a/src/server/Job/Daemon.hs b/src/server/Job/Daemon.hs deleted file mode 100644 index 0bc6f6e..0000000 --- a/src/server/Job/Daemon.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Job.Daemon - ( runDaemons - ) where - -import Control.Concurrent (threadDelay, forkIO, ThreadId) -import Control.Monad (forever) -import Data.Time.Clock (UTCTime) - -import Conf (Conf) -import Job.Frequency (Frequency(..), microSeconds) -import Job.Kind (Kind(..)) -import Job.Model (getLastExecution, actualizeLastCheck, actualizeLastExecution) -import Job.MonthlyPayment (monthlyPayment) -import Job.WeeklyReport (weeklyReport) -import qualified Model.Query as Query -import Utils.Time (belongToCurrentMonth, belongToCurrentWeek) - -runDaemons :: Conf -> IO () -runDaemons conf = do - _ <- runDaemon MonthlyPayment EveryHour (fmap not . belongToCurrentMonth) monthlyPayment - _ <- runDaemon WeeklyReport EveryHour (fmap not . belongToCurrentWeek) (weeklyReport conf) - return () - -runDaemon :: Kind -> Frequency -> (UTCTime -> IO Bool) -> (Maybe UTCTime -> IO UTCTime) -> IO ThreadId -runDaemon kind frequency isLastExecutionTooOld runJob = - forkIO . forever $ do - mbLastExecution <- Query.run $ do - actualizeLastCheck kind - getLastExecution kind - hasToRun <- case mbLastExecution of - Just lastExecution -> isLastExecutionTooOld lastExecution - Nothing -> return True - if hasToRun - then runJob mbLastExecution >>= (Query.run . actualizeLastExecution kind) - else return () - threadDelay . microSeconds $ frequency diff --git a/src/server/Job/Frequency.hs b/src/server/Job/Frequency.hs deleted file mode 100644 index 263f6e6..0000000 --- a/src/server/Job/Frequency.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Job.Frequency - ( Frequency(..) - , microSeconds - ) where - -data Frequency = - EveryHour - | EveryDay - deriving (Eq, Read, Show) - -microSeconds :: Frequency -> Int -microSeconds EveryHour = 1000000 * 60 * 60 -microSeconds EveryDay = (microSeconds EveryHour) * 24 diff --git a/src/server/Job/Kind.hs b/src/server/Job/Kind.hs deleted file mode 100644 index af5d4f8..0000000 --- a/src/server/Job/Kind.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Job.Kind - ( Kind(..) - ) 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 - -data Kind = - MonthlyPayment - | WeeklyReport - deriving (Eq, Show, Read) - -instance FromField Kind where - fromField field = case fieldData field of - SQLText text -> Ok (read (T.unpack text) :: Kind) - _ -> Errors [error "SQLText field required for job kind"] - -instance ToField Kind where - toField kind = SQLText . T.pack . show $ kind diff --git a/src/server/Job/Model.hs b/src/server/Job/Model.hs deleted file mode 100644 index e1a3c77..0000000 --- a/src/server/Job/Model.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Job.Model - ( Job(..) - , getLastExecution - , actualizeLastExecution - , actualizeLastCheck - ) where - -import Data.Maybe (isJust) -import Data.Time.Clock (UTCTime, getCurrentTime) -import Database.SQLite.Simple (Only(Only)) -import qualified Database.SQLite.Simple as SQLite -import Prelude hiding (id) - -import Job.Kind -import Model.Query (Query(Query)) - -data Job = Job - { id :: String - , kind :: Kind - , lastExecution :: Maybe UTCTime - , lastCheck :: Maybe UTCTime - } deriving (Show) - -getLastExecution :: Kind -> Query (Maybe UTCTime) -getLastExecution jobKind = - Query (\conn -> do - [Only time] <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe UTCTime)] - return time - ) - -actualizeLastExecution :: Kind -> UTCTime -> Query () -actualizeLastExecution jobKind time = - Query (\conn -> do - [Only result] <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe Int)] - if isJust result - then SQLite.execute conn "UPDATE job SET last_execution = ? WHERE kind = ?" (time, jobKind) - else SQLite.execute conn "INSERT INTO job (kind, last_execution, last_check) VALUES (?, ?, ?)" (jobKind, time, time) - ) - -actualizeLastCheck :: Kind -> Query () -actualizeLastCheck jobKind = - Query (\conn -> do - now <- getCurrentTime - SQLite.execute conn "UPDATE job SET kind = ? WHERE last_check = ?" (jobKind, now) - ) diff --git a/src/server/Job/MonthlyPayment.hs b/src/server/Job/MonthlyPayment.hs deleted file mode 100644 index ba24cca..0000000 --- a/src/server/Job/MonthlyPayment.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Job.MonthlyPayment - ( monthlyPayment - ) where - -import Data.Time.Clock (UTCTime, getCurrentTime) - -import Common.Model (Frequency(..), Payment(..)) - -import qualified Model.Payment as Payment -import Utils.Time (timeToDay) -import qualified Model.Query as Query - -monthlyPayment :: Maybe UTCTime -> IO UTCTime -monthlyPayment _ = do - monthlyPayments <- Query.run Payment.listMonthly - now <- getCurrentTime - actualDay <- timeToDay now - let punctualPayments = map - (\p -> p - { _payment_frequency = Punctual - , _payment_date = actualDay - , _payment_createdAt = now - }) - monthlyPayments - _ <- Query.run (Payment.createMany punctualPayments) - return now diff --git a/src/server/Job/WeeklyReport.hs b/src/server/Job/WeeklyReport.hs deleted file mode 100644 index 5737c75..0000000 --- a/src/server/Job/WeeklyReport.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Job.WeeklyReport - ( weeklyReport - ) where - -import Data.Time.Clock (UTCTime, getCurrentTime) - -import Conf (Conf) -import qualified Model.Income as Income -import qualified Model.Payment as Payment -import qualified Model.Query as Query -import qualified Model.User as User -import qualified SendMail -import qualified View.Mail.WeeklyReport as WeeklyReport - -weeklyReport :: Conf -> Maybe UTCTime -> IO UTCTime -weeklyReport conf mbLastExecution = do - now <- getCurrentTime - case mbLastExecution of - Nothing -> return () - Just lastExecution -> do - (payments, incomes, users) <- Query.run $ - (,,) <$> - Payment.modifiedDuring lastExecution now <*> - Income.modifiedDuring lastExecution now <*> - User.list - _ <- SendMail.sendMail (WeeklyReport.mail conf users payments incomes lastExecution now) - return () - return now diff --git a/src/server/Json.hs b/src/server/Json.hs deleted file mode 100644 index cc6327a..0000000 --- a/src/server/Json.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} - -module Json - ( jsonObject - , jsonId - ) where - -import Data.Int (Int64) -import Data.Text (Text) -import qualified Data.Aeson.Types as Json -import qualified Data.HashMap.Strict as M -import Web.Scotty - -jsonObject :: [(Text, Json.Value)] -> ActionM () -jsonObject = json . Json.Object . M.fromList - -jsonId :: Int64 -> ActionM () -jsonId key = json . Json.Object . M.fromList $ [("id", Json.Number . fromIntegral $ key)] diff --git a/src/server/LoginSession.hs b/src/server/LoginSession.hs deleted file mode 100644 index 6f6d620..0000000 --- a/src/server/LoginSession.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module LoginSession - ( put - , get - , delete - ) where - -import Web.Scotty (ActionM) -import Cookie (setSimpleCookie, getCookie, deleteCookie) -import qualified Web.ClientSession as CS - -import Control.Monad.IO.Class (liftIO) - -import Data.Text (Text) -import qualified Data.Text.Encoding as TE - -import Conf (Conf) - -sessionName :: Text -sessionName = "SESSION" - -sessionKeyFile :: FilePath -sessionKeyFile = "sessionKey" - -put :: Conf -> Text -> ActionM () -put conf value = do - encrypted <- liftIO $ encrypt value - setSimpleCookie conf sessionName encrypted - -encrypt :: Text -> IO Text -encrypt value = do - iv <- CS.randomIV - key <- CS.getKey sessionKeyFile - return . TE.decodeUtf8 $ CS.encrypt key iv (TE.encodeUtf8 value) - -get :: ActionM (Maybe Text) -get = do - maybeEncrypted <- getCookie sessionName - case maybeEncrypted of - Just encrypted -> - liftIO $ decrypt encrypted - Nothing -> - return Nothing - -decrypt :: Text -> IO (Maybe Text) -decrypt encrypted = do - key <- CS.getKey sessionKeyFile - let decrypted = TE.decodeUtf8 <$> CS.decrypt key (TE.encodeUtf8 encrypted) - return decrypted - -delete :: Conf -> ActionM () -delete conf = deleteCookie conf sessionName diff --git a/src/server/Main.hs b/src/server/Main.hs deleted file mode 100644 index db73474..0000000 --- a/src/server/Main.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Control.Applicative (liftA3) -import Control.Monad.IO.Class (liftIO) - -import Network.Wai.Middleware.Static -import qualified Data.Text.Lazy as LT -import Web.Scotty - -import qualified Conf -import qualified Controller.Category as Category -import qualified Controller.Income as Income -import qualified Controller.Index as Index -import qualified Controller.Payment as Payment -import qualified Controller.SignIn as SignIn -import Job.Daemon (runDaemons) -import Model.Payer (getOrderedExceedingPayers) -import qualified Data.Time as Time -import qualified Model.User as UserM -import qualified Model.Income as IncomeM -import qualified Model.Payment as PaymentM -import qualified Model.Query as Query - -main :: IO () -main = do - conf <- Conf.get "application.conf" - _ <- runDaemons conf - scotty (Conf.port conf) $ do - middleware . staticPolicy $ noDots >-> addBase "public" - - get "/exceedingPayer" $ do - time <- liftIO Time.getCurrentTime - (users, incomes, payments) <- liftIO . Query.run $ - liftA3 (,,) UserM.list IncomeM.list PaymentM.list - let exceedingPayers = getOrderedExceedingPayers time users incomes payments - text . LT.pack . show $ exceedingPayers - - get "/" $ do - signInToken <- mbParam "signInToken" - Index.get conf signInToken - - post "/signIn" $ do - jsonData >>= SignIn.signIn conf - - post "/signOut" $ - Index.signOut conf - - post "/payment" $ - jsonData >>= Payment.create - - put "/payment" $ - jsonData >>= Payment.editOwn - - delete "/payment" $ do - paymentId <- param "id" - Payment.deleteOwn paymentId - - post "/income" $ - jsonData >>= Income.create - - put "/income" $ - jsonData >>= Income.editOwn - - delete "/income" $ do - incomeId <- param "id" - Income.deleteOwn incomeId - - post "/category" $ - jsonData >>= Category.create - - put "/category" $ - jsonData >>= Category.edit - - delete "/category" $ do - categoryId <- param "id" - Category.delete categoryId - -mbParam :: Parsable a => LT.Text -> ActionM (Maybe a) -mbParam key = (Just <$> param key) `rescue` (const . return $ Nothing) diff --git a/src/server/MimeMail.hs b/src/server/MimeMail.hs deleted file mode 100644 index 0faaf98..0000000 --- a/src/server/MimeMail.hs +++ /dev/null @@ -1,672 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module MimeMail - ( -- * Datatypes - Boundary (..) - , Mail (..) - , emptyMail - , Address (..) - , Alternatives - , Part (..) - , Encoding (..) - , Headers - -- * Render a message - , renderMail - , renderMail' - -- * Sending messages - , sendmail - , sendmailCustom - , sendmailCustomCaptureOutput - , renderSendMail - , renderSendMailCustom - -- * High-level 'Mail' creation - , simpleMail - , simpleMail' - , simpleMailInMemory - -- * Utilities - , addPart - , addAttachment - , addAttachmentCid - , addAttachments - , addAttachmentBS - , addAttachmentBSCid - , addAttachmentsBS - , renderAddress - , htmlPart - , plainPart - , randomString - , quotedPrintable - ) where - -import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder.Char.Utf8 -import Blaze.ByteString.Builder -import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar) -import Data.Monoid -import System.Random -import Control.Arrow -import System.Process -import System.IO -import System.Exit -import System.FilePath (takeFileName) -import qualified Data.ByteString.Base64 as Base64 -import Control.Monad ((<=<), foldM, void) -import Control.Exception (throwIO, ErrorCall (ErrorCall)) -import Data.List (intersperse) -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Data.ByteString.Char8 () -import Data.Bits ((.&.), shiftR) -import Data.Char (isAscii, isControl) -import Data.Word (Word8) -import qualified Data.ByteString as S -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE - --- | Generates a random sequence of alphanumerics of the given length. -randomString :: RandomGen d => Int -> d -> (String, d) -randomString len = - first (map toChar) . sequence' (replicate len (randomR (0, 61))) - where - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 - --- | MIME boundary between parts of a message. -newtype Boundary = Boundary { unBoundary :: Text } - deriving (Eq, Show) -instance Random Boundary where - randomR = const random - random = first (Boundary . T.pack) . randomString 10 - --- | An entire mail message. -data Mail = Mail - { mailFrom :: Address - , mailTo :: [Address] - , mailCc :: [Address] - , mailBcc :: [Address] - -- | Other headers, excluding from, to, cc and bcc. - , mailHeaders :: Headers - -- | A list of different sets of alternatives. As a concrete example: - -- - -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]] - -- - -- Make sure when specifying alternatives to place the most preferred - -- version last. - , mailParts :: [Alternatives] - } - deriving Show - --- | A mail message with the provided 'from' address and no other --- fields filled in. -emptyMail :: Address -> Mail -emptyMail from = Mail - { mailFrom = from - , mailTo = [] - , mailCc = [] - , mailBcc = [] - , mailHeaders = [] - , mailParts = [] - } - -data Address = Address - { addressName :: Maybe Text - , addressEmail :: Text - } - deriving (Eq, Show) - --- | How to encode a single part. You should use 'Base64' for binary data. -data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary - deriving (Eq, Show) - --- | Multiple alternative representations of the same data. For example, you --- could provide a plain-text and HTML version of a message. -type Alternatives = [Part] - --- | A single part of a multipart message. -data Part = Part - { partType :: Text -- ^ content type - , partEncoding :: Encoding - -- | The filename for this part, if it is to be sent with an attachemnt - -- disposition. - , partFilename :: Maybe Text - , partHeaders :: Headers - , partContent :: L.ByteString - } - deriving (Eq, Show) - -type Headers = [(S.ByteString, Text)] -type Pair = (Headers, Builder) - -partToPair :: Part -> Pair -partToPair (Part contentType encoding disposition headers content) = - (headers', builder) - where - headers' = - ((:) ("Content-Type", contentType)) - $ (case encoding of - None -> id - Base64 -> (:) ("Content-Transfer-Encoding", "base64") - QuotedPrintableText -> - (:) ("Content-Transfer-Encoding", "quoted-printable") - QuotedPrintableBinary -> - (:) ("Content-Transfer-Encoding", "quoted-printable")) - $ (case disposition of - Nothing -> id - Just fn -> - (:) ("Content-Disposition", "attachment; filename=" - `T.append` fn)) - $ headers - builder = - case encoding of - None -> fromWriteList writeByteString $ L.toChunks content - Base64 -> base64 content - QuotedPrintableText -> quotedPrintable True content - QuotedPrintableBinary -> quotedPrintable False content - -showPairs :: RandomGen g - => Text -- ^ multipart type, eg mixed, alternative - -> [Pair] - -> g - -> (Pair, g) -showPairs _ [] _ = error "renderParts called with null parts" -showPairs _ [pair] gen = (pair, gen) -showPairs mtype parts gen = - ((headers, builder), gen') - where - (Boundary b, gen') = random gen - headers = - [ ("Content-Type", T.concat - [ "multipart/" - , mtype - , "; boundary=\"" - , b - , "\"" - ]) - ] - builder = mconcat - [ mconcat $ intersperse (fromByteString "\n") - $ map (showBoundPart $ Boundary b) parts - , showBoundEnd $ Boundary b - ] - --- | Render a 'Mail' with a given 'RandomGen' for producing boundaries. -renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g) -renderMail g0 (Mail from to cc bcc headers parts) = - (toLazyByteString builder, g'') - where - addressHeaders = map showAddressHeader [("From", [from]), ("To", to), ("Cc", cc), ("Bcc", bcc)] - pairs = map (map partToPair) parts - (pairs', g') = helper g0 $ map (showPairs "alternative") pairs - helper :: g -> [g -> (x, g)] -> ([x], g) - helper g [] = ([], g) - helper g (x:xs) = - let (b, g_) = x g - (bs, g__) = helper g_ xs - in (b : bs, g__) - ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g' - builder = mconcat - [ mconcat addressHeaders - , mconcat $ map showHeader headers - , showHeader ("MIME-Version", "1.0") - , mconcat $ map showHeader finalHeaders - , fromByteString "\n" - , finalBuilder - ] - --- | Format an E-Mail address according to the name-addr form (see: RFC5322 --- § 3.4 "Address specification", i.e: [display-name] '<'addr-spec'>') --- This can be handy for adding custom headers that require such format. --- --- @since 0.4.11 -renderAddress :: Address -> Text -renderAddress address = - TE.decodeUtf8 $ toByteString $ showAddress address - --- Only accept characters between 33 and 126, excluding colons. [RFC2822](https://tools.ietf.org/html/rfc2822#section-2.2) -sanitizeFieldName :: S.ByteString -> S.ByteString -sanitizeFieldName = S.filter (\w -> w >= 33 && w <= 126 && w /= 58) - -showHeader :: (S.ByteString, Text) -> Builder -showHeader (k, v) = mconcat - [ fromByteString (sanitizeFieldName k) - , fromByteString ": " - , encodeIfNeeded (sanitizeHeader v) - , fromByteString "\n" - ] - -showAddressHeader :: (S.ByteString, [Address]) -> Builder -showAddressHeader (k, as) = - if null as - then mempty - else mconcat - [ fromByteString k - , fromByteString ": " - , mconcat (intersperse (fromByteString ", ") . map showAddress $ as) - , fromByteString "\n" - ] - --- | --- --- Since 0.4.3 -showAddress :: Address -> Builder -showAddress a = mconcat - [ maybe mempty ((<> fromByteString " ") . encodedWord) (addressName a) - , fromByteString "<" - , fromText (sanitizeHeader $ addressEmail a) - , fromByteString ">" - ] - --- Filter out control characters to prevent CRLF injection. -sanitizeHeader :: Text -> Text -sanitizeHeader = T.filter (not . isControl) - -showBoundPart :: Boundary -> (Headers, Builder) -> Builder -showBoundPart (Boundary b) (headers, content) = mconcat - [ fromByteString "--" - , fromText b - , fromByteString "\n" - , mconcat $ map showHeader headers - , fromByteString "\n" - , content - ] - -showBoundEnd :: Boundary -> Builder -showBoundEnd (Boundary b) = mconcat - [ fromByteString "\n--" - , fromText b - , fromByteString "--" - ] - --- | Like 'renderMail', but generates a random boundary. -renderMail' :: Mail -> IO L.ByteString -renderMail' m = do - g <- getStdGen - let (lbs, g') = renderMail g m - setStdGen g' - return lbs - --- | Send a fully-formed email message via the default sendmail --- executable with default options. -sendmail :: L.ByteString -> IO () -sendmail = sendmailCustom sendmailPath ["-t"] - -sendmailPath :: String -sendmailPath = "sendmail" - --- | Render an email message and send via the default sendmail --- executable with default options. -renderSendMail :: Mail -> IO () -renderSendMail = sendmail <=< renderMail' - --- | Send a fully-formed email message via the specified sendmail --- executable with specified options. -sendmailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> L.ByteString -- ^ mail message as lazy bytestring - -> IO () -sendmailCustom sm opts lbs = void $ sendmailCustomAux False sm opts lbs - --- | Like 'sendmailCustom', but also returns sendmail's output to stderr and --- stdout as strict ByteStrings. --- --- Since 0.4.9 -sendmailCustomCaptureOutput :: FilePath - -> [String] - -> L.ByteString - -> IO (S.ByteString, S.ByteString) -sendmailCustomCaptureOutput sm opts lbs = sendmailCustomAux True sm opts lbs - -sendmailCustomAux :: Bool - -> FilePath - -> [String] - -> L.ByteString - -> IO (S.ByteString, S.ByteString) -sendmailCustomAux captureOut sm opts lbs = do - let baseOpts = (proc sm opts) { std_in = CreatePipe } - pOpts = if captureOut - then baseOpts { std_out = CreatePipe - , std_err = CreatePipe - } - else baseOpts - (Just hin, mHOut, mHErr, phandle) <- createProcess pOpts - L.hPut hin lbs - hClose hin - errMVar <- newEmptyMVar - outMVar <- newEmptyMVar - case (mHOut, mHErr) of - (Nothing, Nothing) -> return () - (Just hOut, Just hErr) -> do - void . forkIO $ S.hGetContents hOut >>= putMVar outMVar - void . forkIO $ S.hGetContents hErr >>= putMVar errMVar - _ -> error "error in sendmailCustomAux: missing a handle" - exitCode <- waitForProcess phandle - case exitCode of - ExitSuccess -> if captureOut - then do - errOutput <- takeMVar errMVar - outOutput <- takeMVar outMVar - return (outOutput, errOutput) - else return (S.empty, S.empty) - _ -> throwIO $ ErrorCall ("sendmail exited with error code " ++ show exitCode) - --- | Render an email message and send via the specified sendmail --- executable with specified options. -renderSendMailCustom :: FilePath -- ^ sendmail executable path - -> [String] -- ^ sendmail command-line options - -> Mail -- ^ mail to render and send - -> IO () -renderSendMailCustom sm opts = sendmailCustom sm opts <=< renderMail' - --- FIXME usage of FilePath below can lead to issues with filename encoding - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some file attachments. --- --- Note that we use lazy IO for reading in the attachment contents. -simpleMail :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, FilePath)] -- ^ content type and path of attachments - -> IO Mail -simpleMail to from subject plainBody htmlBody attachments = - addAttachments attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with only plain-text body. -simpleMail' :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ body - -> Mail -simpleMail' to from subject body = addPart [plainPart body] - $ mailFromToSubject from to subject - --- | A simple interface for generating an email with HTML and plain-text --- alternatives and some 'ByteString' attachments. --- --- Since 0.4.7 -simpleMailInMemory :: Address -- ^ to - -> Address -- ^ from - -> Text -- ^ subject - -> LT.Text -- ^ plain body - -> LT.Text -- ^ HTML body - -> [(Text, Text, L.ByteString)] -- ^ content type, file name and contents of attachments - -> Mail -simpleMailInMemory to from subject plainBody htmlBody attachments = - addAttachmentsBS attachments - . addPart [plainPart plainBody, htmlPart htmlBody] - $ mailFromToSubject from to subject - -mailFromToSubject :: Address -- ^ from - -> Address -- ^ to - -> Text -- ^ subject - -> Mail -mailFromToSubject from to subject = - (emptyMail from) { mailTo = [to] - , mailHeaders = [("Subject", subject)] - } - --- | Add an 'Alternative' to the 'Mail's parts. --- --- To e.g. add a plain text body use --- > addPart [plainPart body] (emptyMail from) -addPart :: Alternatives -> Mail -> Mail -addPart alt mail = mail { mailParts = mailParts mail ++ [alt] } - --- | Construct a UTF-8-encoded plain-text 'Part'. -plainPart :: LT.Text -> Part -plainPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body - where cType = "text/plain; charset=utf-8" - --- | Construct a UTF-8-encoded html 'Part'. -htmlPart :: LT.Text -> Part -htmlPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body - where cType = "text/html; charset=utf-8" - --- | Add an attachment from a file and construct a 'Part'. -addAttachment :: Text -> FilePath -> Mail -> IO Mail -addAttachment ct fn mail = do - part <- getAttachmentPart ct fn - return $ addPart [part] mail - --- | Add an attachment from a file and construct a 'Part' --- with the specified content id in the Content-ID header. --- --- @since 0.4.12 -addAttachmentCid :: Text -- ^ content type - -> FilePath -- ^ file name - -> Text -- ^ content ID - -> Mail - -> IO Mail -addAttachmentCid ct fn cid mail = - getAttachmentPart ct fn >>= (return.addToMail.addHeader) - where - addToMail part = addPart [part] mail - addHeader part = part { partHeaders = header:ph } - where ph = partHeaders part - header = ("Content-ID", T.concat ["<", cid, ">"]) - -addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail -addAttachments xs mail = foldM fun mail xs - where fun m (c, f) = addAttachment c f m - --- | Add an attachment from a 'ByteString' and construct a 'Part'. --- --- Since 0.4.7 -addAttachmentBS :: Text -- ^ content type - -> Text -- ^ file name - -> L.ByteString -- ^ content - -> Mail -> Mail -addAttachmentBS ct fn content mail = - let part = getAttachmentPartBS ct fn content - in addPart [part] mail - --- | @since 0.4.12 -addAttachmentBSCid :: Text -- ^ content type - -> Text -- ^ file name - -> L.ByteString -- ^ content - -> Text -- ^ content ID - -> Mail -> Mail -addAttachmentBSCid ct fn content cid mail = - let part = addHeader $ getAttachmentPartBS ct fn content - in addPart [part] mail - where - addHeader part = part { partHeaders = header:ph } - where ph = partHeaders part - header = ("Content-ID", T.concat ["<", cid, ">"]) - --- | --- Since 0.4.7 -addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail -addAttachmentsBS xs mail = foldl fun mail xs - where fun m (ct, fn, content) = addAttachmentBS ct fn content m - -getAttachmentPartBS :: Text - -> Text - -> L.ByteString - -> Part -getAttachmentPartBS ct fn content = Part ct Base64 (Just fn) [] content - -getAttachmentPart :: Text -> FilePath -> IO Part -getAttachmentPart ct fn = do - content <- L.readFile fn - return $ getAttachmentPartBS ct (T.pack (takeFileName fn)) content - -data QP = QPPlain S.ByteString - | QPNewline - | QPTab - | QPSpace - | QPEscape S.ByteString - -data QPC = QPCCR - | QPCLF - | QPCSpace - | QPCTab - | QPCPlain - | QPCEscape - deriving Eq - -toQP :: Bool -- ^ text? - -> L.ByteString - -> [QP] -toQP isText = - go - where - go lbs = - case L.uncons lbs of - Nothing -> [] - Just (c, rest) -> - case toQPC c of - QPCCR -> go rest - QPCLF -> QPNewline : go rest - QPCSpace -> QPSpace : go rest - QPCTab -> QPTab : go rest - QPCPlain -> - let (x, y) = L.span ((== QPCPlain) . toQPC) lbs - in QPPlain (toStrict x) : go y - QPCEscape -> - let (x, y) = L.span ((== QPCEscape) . toQPC) lbs - in QPEscape (toStrict x) : go y - - toStrict = S.concat . L.toChunks - - toQPC :: Word8 -> QPC - toQPC 13 | isText = QPCCR - toQPC 10 | isText = QPCLF - toQPC 9 = QPCTab - toQPC 0x20 = QPCSpace - toQPC 46 = QPCEscape - toQPC 61 = QPCEscape - toQPC w - | 33 <= w && w <= 126 = QPCPlain - | otherwise = QPCEscape - -buildQPs :: [QP] -> Builder -buildQPs = - go (0 :: Int) - where - go _ [] = mempty - go currLine (qp:qps) = - case qp of - QPNewline -> copyByteString "\r\n" `mappend` go 0 qps - QPTab -> wsHelper (copyByteString "=09") (fromWord8 9) - QPSpace -> wsHelper (copyByteString "=20") (fromWord8 0x20) - QPPlain bs -> - let toTake = 75 - currLine - (x, y) = S.splitAt toTake bs - rest - | S.null y = qps - | otherwise = QPPlain y : qps - in helper (S.length x) (copyByteString x) (S.null y) rest - QPEscape bs -> - let toTake = (75 - currLine) `div` 3 - (x, y) = S.splitAt toTake bs - rest - | S.null y = qps - | otherwise = QPEscape y : qps - in if toTake == 0 - then copyByteString "=\r\n" `mappend` go 0 (qp:qps) - else helper (S.length x * 3) (escape x) (S.null y) rest - where - escape = - S.foldl' add mempty - where - add builder w = - builder `mappend` escaped - where - escaped = fromWord8 61 `mappend` hex (w `shiftR` 4) - `mappend` hex (w .&. 15) - - helper added builder noMore rest = - builder' `mappend` go newLine rest - where - (newLine, builder') - | not noMore || (added + currLine) >= 75 = - (0, builder `mappend` copyByteString "=\r\n") - | otherwise = (added + currLine, builder) - - wsHelper enc raw - | null qps = - if currLine <= 73 - then enc - else copyByteString "\r\n=" `mappend` enc - | otherwise = helper 1 raw (currLine < 76) qps - --- | The first parameter denotes whether the input should be treated as text. --- If treated as text, then CRs will be stripped and LFs output as CRLFs. If --- binary, then CRs and LFs will be escaped. -quotedPrintable :: Bool -> L.ByteString -> Builder -quotedPrintable isText = buildQPs . toQP isText - -hex :: Word8 -> Builder -hex x - | x < 10 = fromWord8 $ x + 48 - | otherwise = fromWord8 $ x + 55 - -encodeIfNeeded :: Text -> Builder -encodeIfNeeded t = - if needsEncodedWord t - then encodedWord t - else fromText t - -needsEncodedWord :: Text -> Bool -needsEncodedWord = not . T.all isAscii - -encodedWord :: Text -> Builder -encodedWord t = mconcat - [ fromByteString "=?utf-8?Q?" - , S.foldl' go mempty $ TE.encodeUtf8 t - , fromByteString "?=" - ] - where - go front w = front `mappend` go' w - go' 32 = fromWord8 95 -- space - go' 95 = go'' 95 -- _ - go' 63 = go'' 63 -- ? - go' 61 = go'' 61 -- = - - -- The special characters from RFC 2822. Not all of these always give - -- problems, but at least @[];"<>, gave problems with some mail servers - -- when used in the 'name' part of an address. - go' 34 = go'' 34 -- " - go' 40 = go'' 40 -- ( - go' 41 = go'' 41 -- ) - go' 44 = go'' 44 -- , - go' 46 = go'' 46 -- . - go' 58 = go'' 58 -- ; - go' 59 = go'' 59 -- ; - go' 60 = go'' 60 -- < - go' 62 = go'' 62 -- > - go' 64 = go'' 64 -- @ - go' 91 = go'' 91 -- [ - go' 92 = go'' 92 -- \ - go' 93 = go'' 93 -- ] - go' w - | 33 <= w && w <= 126 = fromWord8 w - | otherwise = go'' w - go'' w = fromWord8 61 `mappend` hex (w `shiftR` 4) - `mappend` hex (w .&. 15) - --- 57 bytes, when base64-encoded, becomes 76 characters. --- Perform the encoding 57-bytes at a time, and then append a newline. -base64 :: L.ByteString -> Builder -base64 lbs - | L.null lbs = mempty - | otherwise = fromByteString x64 `mappend` - fromByteString "\r\n" `mappend` - base64 y - where - (x', y) = L.splitAt 57 lbs - x = S.concat $ L.toChunks x' - x64 = Base64.encode x diff --git a/src/server/Model/Category.hs b/src/server/Model/Category.hs deleted file mode 100644 index 6b7a488..0000000 --- a/src/server/Model/Category.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# 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/src/server/Model/Frequency.hs b/src/server/Model/Frequency.hs deleted file mode 100644 index 4f7b83d..0000000 --- a/src/server/Model/Frequency.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# 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 (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/src/server/Model/Income.hs b/src/server/Model/Income.hs deleted file mode 100644 index bbe7657..0000000 --- a/src/server/Model/Income.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# 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/src/server/Model/Init.hs b/src/server/Model/Init.hs deleted file mode 100644 index 8c6a961..0000000 --- a/src/server/Model/Init.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# 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/src/server/Model/Mail.hs b/src/server/Model/Mail.hs deleted file mode 100644 index 9a4db73..0000000 --- a/src/server/Model/Mail.hs +++ /dev/null @@ -1,12 +0,0 @@ -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/src/server/Model/Payer.hs b/src/server/Model/Payer.hs deleted file mode 100644 index de4abd1..0000000 --- a/src/server/Model/Payer.hs +++ /dev/null @@ -1,216 +0,0 @@ -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/src/server/Model/Payment.hs b/src/server/Model/Payment.hs deleted file mode 100644 index 3893850..0000000 --- a/src/server/Model/Payment.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# 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 -import Common.Model.Payment (Payment(..)) -import Common.Model.User (UserId) -import Common.Model.Payment (PaymentId) - -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/src/server/Model/PaymentCategory.hs b/src/server/Model/PaymentCategory.hs deleted file mode 100644 index 6e1d304..0000000 --- a/src/server/Model/PaymentCategory.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# 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/src/server/Model/Query.hs b/src/server/Model/Query.hs deleted file mode 100644 index d15fb5f..0000000 --- a/src/server/Model/Query.hs +++ /dev/null @@ -1,32 +0,0 @@ -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/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs deleted file mode 100644 index c5182f0..0000000 --- a/src/server/Model/SignIn.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# 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/src/server/Model/UUID.hs b/src/server/Model/UUID.hs deleted file mode 100644 index 6cb7ce0..0000000 --- a/src/server/Model/UUID.hs +++ /dev/null @@ -1,10 +0,0 @@ -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/src/server/Model/User.hs b/src/server/Model/User.hs deleted file mode 100644 index e14fcef..0000000 --- a/src/server/Model/User.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# 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) - ) diff --git a/src/server/Resource.hs b/src/server/Resource.hs deleted file mode 100644 index f52bbfa..0000000 --- a/src/server/Resource.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Resource - ( Resource - , resourceCreatedAt - , resourceEditedAt - , resourceDeletedAt - , Status(..) - , statuses - , groupByStatus - , statusDuring - ) where - -import Data.Maybe (fromMaybe) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Time.Clock (UTCTime) - -class Resource a where - resourceCreatedAt :: a -> UTCTime - resourceEditedAt :: a -> Maybe UTCTime - resourceDeletedAt :: a -> Maybe UTCTime - -data Status = - Created - | Edited - | Deleted - deriving (Eq, Show, Read, Ord, Enum, Bounded) - -statuses :: [Status] -statuses = [minBound..] - -groupByStatus :: Resource a => UTCTime -> UTCTime -> [a] -> Map Status [a] -groupByStatus start end resources = - foldl - (\m resource -> - case statusDuring start end resource of - Just status -> M.insertWith (++) status [resource] m - Nothing -> m - ) - M.empty - resources - -statusDuring :: Resource a => UTCTime -> UTCTime -> a -> Maybe Status -statusDuring start end resource - | created && not deleted = Just Created - | not created && edited && not deleted = Just Edited - | not created && deleted = Just Deleted - | otherwise = Nothing - where - created = belongs (resourceCreatedAt resource) start end - edited = fromMaybe False (fmap (\t -> belongs t start end) $ resourceEditedAt resource) - deleted = fromMaybe False (fmap (\t -> belongs t start end) $ resourceDeletedAt resource) - -belongs :: UTCTime -> UTCTime -> UTCTime -> Bool -belongs time start end = time >= start && time < end diff --git a/src/server/Secure.hs b/src/server/Secure.hs deleted file mode 100644 index f427304..0000000 --- a/src/server/Secure.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Secure - ( loggedAction - , getUserFromToken - ) where - -import Control.Monad.IO.Class (liftIO) -import Data.Text (Text) -import Data.Text.Lazy (fromStrict) -import Network.HTTP.Types.Status (forbidden403) -import Web.Scotty - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (User) - -import Model.Query (Query) -import qualified LoginSession -import qualified Model.Query as Query -import qualified Model.SignIn as SignIn -import qualified Model.User as User - -loggedAction :: (User -> ActionM ()) -> ActionM () -loggedAction action = do - maybeToken <- LoginSession.get - case maybeToken of - Just token -> do - maybeUser <- liftIO . Query.run . getUserFromToken $ token - case maybeUser of - Just user -> - action user - Nothing -> do - status forbidden403 - html . fromStrict . Message.get $ Key.Secure_Unauthorized - Nothing -> do - status forbidden403 - html . fromStrict . Message.get $ Key.Secure_Forbidden - -getUserFromToken :: Text -> Query (Maybe User) -getUserFromToken token = do - mbSignIn <- SignIn.getSignIn token - case mbSignIn of - Just signIn -> - User.get (SignIn.email signIn) - Nothing -> - return Nothing diff --git a/src/server/SendMail.hs b/src/server/SendMail.hs deleted file mode 100644 index f7ba3fd..0000000 --- a/src/server/SendMail.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module SendMail - ( sendMail - ) where - -import Control.Arrow (left) -import Control.Exception (SomeException, try) -import Data.Either (isLeft) - -import Data.Text (Text) -import Data.Text.Lazy.Builder (toLazyText, fromText) -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified MimeMail as M - -import Model.Mail (Mail(Mail)) - -sendMail :: Mail -> IO (Either Text ()) -sendMail mail = do - result <- left (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ())) - if isLeft result - then putStrLn ("Error sending the following email:" ++ (show mail) ++ "\n" ++ (show result)) - else putStrLn "OK" - return result - -getMimeMail :: Mail -> M.Mail -getMimeMail (Mail mailFrom mailTo mailSubject mailPlainBody) = - let fromMail = M.emptyMail (address mailFrom) - in fromMail - { M.mailTo = map address mailTo - , M.mailParts = [ [ M.plainPart . strictToLazy $ mailPlainBody ] ] - , M.mailHeaders = [("Subject", mailSubject)] - } - -address :: Text -> M.Address -address addressEmail = - M.Address - { M.addressName = Nothing - , M.addressEmail = addressEmail - } - -strictToLazy :: Text -> LT.Text -strictToLazy = toLazyText . fromText diff --git a/src/server/Utils/Time.hs b/src/server/Utils/Time.hs deleted file mode 100644 index 97457c7..0000000 --- a/src/server/Utils/Time.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Utils.Time - ( belongToCurrentMonth - , belongToCurrentWeek - , timeToDay - ) where - -import Data.Time.Clock (UTCTime, getCurrentTime) -import Data.Time.LocalTime -import Data.Time.Calendar -import Data.Time.Calendar.WeekDate (toWeekDate) - -belongToCurrentMonth :: UTCTime -> IO Bool -belongToCurrentMonth time = do - (timeYear, timeMonth, _) <- toGregorian <$> timeToDay time - (actualYear, actualMonth, _) <- toGregorian <$> (getCurrentTime >>= timeToDay) - return (actualYear == timeYear && actualMonth == timeMonth) - -belongToCurrentWeek :: UTCTime -> IO Bool -belongToCurrentWeek time = do - (timeYear, timeWeek, _) <- toWeekDate <$> timeToDay time - (actualYear, actualWeek, _) <- toWeekDate <$> (getCurrentTime >>= timeToDay) - return (actualYear == timeYear && actualWeek == timeWeek) - -timeToDay :: UTCTime -> IO Day -timeToDay time = localDay . (flip utcToLocalTime time) <$> getTimeZone time diff --git a/src/server/Validation.hs b/src/server/Validation.hs deleted file mode 100644 index 1f332c9..0000000 --- a/src/server/Validation.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Validation - ( nonEmpty - , number - ) where - -import Data.Text (Text) -import qualified Data.Text as T - -nonEmpty :: Text -> Maybe Text -nonEmpty str = - if T.null str - then Nothing - else Just str - -number :: (Int -> Bool) -> Text -> Maybe Int -number numberForm str = - case reads (T.unpack str) :: [(Int, String)] of - (num, _) : _ -> - if numberForm num - then Just num - else Nothing - _ -> - Nothing diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs deleted file mode 100644 index 12c4f34..0000000 --- a/src/server/View/Mail/SignIn.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Mail.SignIn - ( mail - ) where - -import Data.Text (Text) - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model.User (User(..)) - -import Conf (Conf) -import qualified Conf as Conf -import qualified Model.Mail as M - -mail :: Conf -> User -> Text -> [Text] -> M.Mail -mail conf user url to = - M.Mail - { M.from = Conf.noReplyMail conf - , M.to = to - , M.subject = Message.get Key.SignIn_MailTitle - , M.plainBody = Message.get (Key.SignIn_MailBody (_user_name user) url) - } diff --git a/src/server/View/Mail/WeeklyReport.hs b/src/server/View/Mail/WeeklyReport.hs deleted file mode 100644 index 0bafb70..0000000 --- a/src/server/View/Mail/WeeklyReport.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Mail.WeeklyReport - ( mail - ) where - -import Data.List (sortOn) -import Data.Map (Map) -import Data.Maybe (catMaybes, fromMaybe) -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import qualified Data.Map as M -import qualified Data.Text as T - -import qualified Common.Message as Message -import qualified Common.Message.Key as Key -import Common.Model (Payment(..), User(..), UserId, Income(..)) -import qualified Common.Model.User as User -import qualified Common.View.Format as Format - -import Model.Mail (Mail(Mail)) -import Model.Payment () -import qualified Model.Income () -import qualified Model.Mail as M -import Resource (Status(..), groupByStatus, statuses) -import Conf (Conf) -import qualified Conf as Conf - -mail :: Conf -> [User] -> [Payment] -> [Income] -> UTCTime -> UTCTime -> Mail -mail conf users payments incomes start end = - Mail - { M.from = Conf.noReplyMail conf - , M.to = map _user_email users - , M.subject = T.concat - [ Message.get Key.App_Title - , " − " - , Message.get Key.WeeklyReport_Title - ] - , M.plainBody = body conf users (groupByStatus start end payments) (groupByStatus start end incomes) - } - -body :: Conf -> [User] -> Map Status [Payment] -> Map Status [Income] -> Text -body conf users paymentsByStatus incomesByStatus = - if M.null paymentsByStatus && M.null incomesByStatus - then - Message.get Key.WeeklyReport_Empty - else - T.intercalate "\n" . catMaybes . concat $ - [ map (\s -> paymentSection s conf users <$> M.lookup s paymentsByStatus) statuses - , map (\s -> incomeSection s conf users <$> M.lookup s incomesByStatus) statuses - ] - -paymentSection :: Status -> Conf -> [User] -> [Payment] -> Text -paymentSection status conf users payments = - section sectionTitle sectionItems - where count = length payments - sectionTitle = Message.get $ case status of - Created -> if count > 1 then Key.WeeklyReport_PaymentsCreated count else Key.WeeklyReport_PaymentCreated count - Edited -> if count > 1 then Key.WeeklyReport_PaymentsEdited count else Key.WeeklyReport_PaymentEdited count - Deleted -> if count > 1 then Key.WeeklyReport_PaymentsDeleted count else Key.WeeklyReport_PaymentDeleted count - sectionItems = map (payedFor status conf users) . sortOn _payment_date $ payments - -payedFor :: Status -> Conf -> [User] -> Payment -> Text -payedFor status conf users payment = - case status of - Deleted -> Message.get (Key.WeeklyReport_PayedForNot name amount for at) - _ -> Message.get (Key.WeeklyReport_PayedFor name amount for at) - where name = formatUserName (_payment_user payment) users - amount = Format.price (Conf.currency conf) . _payment_cost $ payment - for = _payment_name payment - at = Format.longDay $ _payment_date payment - -incomeSection :: Status -> Conf -> [User] -> [Income] -> Text -incomeSection status conf users incomes = - section sectionTitle sectionItems - where count = length incomes - sectionTitle = Message.get $ case status of - Created -> if count > 1 then Key.WeeklyReport_IncomesCreated count else Key.WeeklyReport_IncomeCreated count - Edited -> if count > 1 then Key.WeeklyReport_IncomesEdited count else Key.WeeklyReport_IncomeEdited count - Deleted -> if count > 1 then Key.WeeklyReport_IncomesDeleted count else Key.WeeklyReport_IncomeDeleted count - sectionItems = map (isPayedFrom status conf users) . sortOn _income_date $ incomes - -isPayedFrom :: Status -> Conf -> [User] -> Income -> Text -isPayedFrom status conf users income = - case status of - Deleted -> Message.get (Key.WeeklyReport_PayedFromNot name amount for) - _ -> Message.get (Key.WeeklyReport_PayedFrom name amount for) - where name = formatUserName (_income_userId income) users - amount = Format.price (Conf.currency conf) . _income_amount $ income - for = Format.longDay $ _income_date income - -formatUserName :: UserId -> [User] -> Text -formatUserName userId = fromMaybe "−" . fmap _user_name . User.find userId - -section :: Text -> [Text] -> Text -section title items = - T.concat - [ title - , "\n\n" - , T.unlines . map (" - " <>) $ items - ] diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs deleted file mode 100644 index 1c072a4..0000000 --- a/src/server/View/Page.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module View.Page - ( page - ) where - -import Data.Text.Internal.Lazy (Text) -import Data.Text.Lazy.Encoding (decodeUtf8) -import Data.Aeson (encode) -import qualified Data.Aeson.Types as Json - -import Text.Blaze.Html -import Text.Blaze.Html5 -import qualified Text.Blaze.Html5 as H -import Text.Blaze.Html5.Attributes -import qualified Text.Blaze.Html5.Attributes as A -import Text.Blaze.Html.Renderer.Text (renderHtml) - -import qualified Common.Message as Message -import Common.Model.InitResult (InitResult) -import qualified Common.Message.Key as Key - -import Design.Global (globalDesign) - -page :: InitResult -> Text -page initResult = - renderHtml . docTypeHtml $ do - H.head $ do - meta ! charset "UTF-8" - meta ! name "viewport" ! content "width=device-width, initial-scale=1, maximum-scale=1, user-scalable=0" - H.title (toHtml $ Message.get Key.App_Title) - script ! src "javascript/main.js" $ "" - jsonScript "init" initResult - link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" - link ! rel "icon" ! type_ "image/png" ! href "images/icon.png" - H.style $ toHtml globalDesign - -jsonScript :: Json.ToJSON a => Text -> a -> Html -jsonScript scriptId json = - script - ! A.id (toValue scriptId) - ! type_ "application/json" - $ toHtml . decodeUtf8 . encode $ json |