aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Controller/Index.hs58
-rw-r--r--src/server/Controller/Payment.hs31
-rw-r--r--src/server/Controller/SignIn.hs (renamed from src/server/Application.hs)94
-rw-r--r--src/server/Main.hs4
-rw-r--r--src/server/Model/Mail.hs13
-rw-r--r--src/server/SendMail.hs (renamed from src/server/Mail.hs)27
-rw-r--r--src/server/View/Mail/SignIn.hs48
-rw-r--r--src/server/View/Page.hs1
8 files changed, 177 insertions, 99 deletions
diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs
new file mode 100644
index 0000000..610c57c
--- /dev/null
+++ b/src/server/Controller/Index.hs
@@ -0,0 +1,58 @@
+module Controller.Index
+ ( getIndexAction
+ , getUserName
+ , signOutAction
+ , getUsersAction
+ , addUserAction
+ , deleteUserAction
+ ) where
+
+import Web.Scotty
+
+import Network.HTTP.Types.Status (ok200)
+
+import Database.Persist
+
+import Control.Monad.IO.Class (liftIO)
+
+import Data.Text (Text)
+import Data.String (fromString)
+
+import qualified LoginSession
+
+import qualified Secure
+
+import Model.Database
+import Model.User
+import Model.Message
+
+import View.Page (page)
+
+getIndexAction :: ActionM ()
+getIndexAction = html page
+
+getUserName :: ActionM ()
+getUserName =
+ Secure.loggedAction (\user -> do
+ json . Message . userName . entityVal $ user
+ )
+
+signOutAction :: ActionM ()
+signOutAction = do
+ LoginSession.delete
+ status ok200
+
+getUsersAction :: ActionM ()
+getUsersAction = do
+ users <- liftIO $ runDb getUsers
+ html . fromString . show $ users
+
+addUserAction :: Text -> Text -> ActionM ()
+addUserAction email name = do
+ _ <- liftIO . runDb $ createUser email name
+ status ok200
+
+deleteUserAction :: Text -> ActionM ()
+deleteUserAction email = do
+ _ <- liftIO . runDb $ deleteUser email
+ status ok200
diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs
new file mode 100644
index 0000000..1287825
--- /dev/null
+++ b/src/server/Controller/Payment.hs
@@ -0,0 +1,31 @@
+module Controller.Payment
+ ( getPaymentsAction
+ , createPaymentAction
+ ) where
+
+import Web.Scotty
+
+import Database.Persist
+
+import Control.Monad.IO.Class (liftIO)
+
+import Data.Text (Text)
+
+import qualified Secure
+
+import Model.Database
+import Model.Payment
+
+getPaymentsAction :: ActionM ()
+getPaymentsAction =
+ Secure.loggedAction (\_ -> do
+ payments <- liftIO $ runDb getPayments
+ json payments
+ )
+
+createPaymentAction :: Text -> Int -> ActionM ()
+createPaymentAction name cost =
+ Secure.loggedAction (\user -> do
+ _ <- liftIO . runDb $ createPayment (entityKey user) name cost
+ return ()
+ )
diff --git a/src/server/Application.hs b/src/server/Controller/SignIn.hs
index 5306e17..a46894a 100644
--- a/src/server/Application.hs
+++ b/src/server/Controller/SignIn.hs
@@ -1,17 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
-module Application
+module Controller.SignIn
( signInAction
, validateSignInAction
- , getUserName
- , getPaymentsAction
- , createPaymentAction
- , signOutAction
-
- , getIndexAction
- , getUsersAction
- , addUserAction
- , deleteUserAction
) where
import Web.Scotty
@@ -26,49 +17,48 @@ import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as TE
-import Data.String (fromString)
import Data.Time.Clock (getCurrentTime, diffUTCTime)
-import Data.Maybe (isJust)
-
-import Text.Email.Validate (isValid)
import qualified LoginSession
-import qualified Secure
+import Config
+
+import SendMail
+
+import Text.Email.Validate (isValid)
import Model.Database
import Model.User
-import Model.Payment
import Model.SignIn
import Model.Message
-import Config
-
-import View.Page (page)
-
-import Mail
+import qualified View.Mail.SignIn as SignIn
signInAction :: Config -> Text -> ActionM ()
signInAction config login =
if isValid (TE.encodeUtf8 login)
then do
maybeUser <- liftIO . runDb $ getUser login
- if isJust maybeUser
- then do
+ case maybeUser of
+ Just user -> do
token <- liftIO . runDb $ createSignInToken login
let url = T.concat ["http://", hostname config, "/validateSignIn?token=", token]
- let mail = Mail [login] "Sign in" url url
- maybeSentMail <- liftIO . sendMail $ mail
+ maybeSentMail <- liftIO . sendMail $ SignIn.getMail (entityVal user) url [login]
case maybeSentMail of
Right _ ->
status ok200
Left _ ->
errorResponse "Sorry, we failed to send you the sign up email."
- else
+ Nothing ->
errorResponse "You are not authorized to sign in."
else
errorResponse "Please enter a valid email address."
+errorResponse :: Text -> ActionM ()
+errorResponse msg = do
+ status badRequest400
+ json (Message msg)
+
validateSignInAction :: Text -> ActionM ()
validateSignInAction token = do
maybeSignIn <- liftIO . runDb $ getSignInToken token
@@ -93,55 +83,3 @@ validateSignInAction token = do
redirectError :: Text -> ActionM ()
redirectError msg =
redirect . TL.fromStrict . T.concat $ ["/?signInError=", msg]
-
-getUserName :: ActionM ()
-getUserName =
- Secure.loggedAction (\user -> do
- json . Message . userName . entityVal $ user
- )
-
-getPaymentsAction :: ActionM ()
-getPaymentsAction =
- Secure.loggedAction (\_ -> do
- payments <- liftIO $ runDb getPayments
- json payments
- )
-
-createPaymentAction :: Text -> Int -> ActionM ()
-createPaymentAction name cost =
- Secure.loggedAction (\user -> do
- _ <- liftIO . runDb $ createPayment (entityKey user) name cost
- return ()
- )
-
-signOutAction :: ActionM ()
-signOutAction = do
- LoginSession.delete
- status ok200
-
-errorResponse :: Text -> ActionM ()
-errorResponse msg = do
- status badRequest400
- json (Message msg)
-
-
-
-
-
-getIndexAction :: ActionM ()
-getIndexAction = html page
-
-getUsersAction :: ActionM ()
-getUsersAction = do
- users <- liftIO $ runDb getUsers
- html . fromString . show $ users
-
-addUserAction :: Text -> Text -> ActionM ()
-addUserAction email name = do
- _ <- liftIO . runDb $ createUser email name
- status ok200
-
-deleteUserAction :: Text -> ActionM ()
-deleteUserAction email = do
- _ <- liftIO . runDb $ deleteUser email
- status ok200
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 3033f58..e7e759b 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -6,7 +6,9 @@ import Network.Wai.Middleware.Static
import Data.Text (Text)
-import Application
+import Controller.Index
+import Controller.SignIn
+import Controller.Payment
import Model.Database (runMigrations)
diff --git a/src/server/Model/Mail.hs b/src/server/Model/Mail.hs
new file mode 100644
index 0000000..7ee8a8e
--- /dev/null
+++ b/src/server/Model/Mail.hs
@@ -0,0 +1,13 @@
+module Model.Mail
+ ( Mail(..)
+ ) where
+
+import Data.Text (Text)
+import qualified Data.Text.Lazy as LT
+
+data Mail = Mail
+ { to :: [Text]
+ , subject :: Text
+ , plainBody :: LT.Text
+ , htmlBody :: LT.Text
+ } deriving (Eq, Show)
diff --git a/src/server/Mail.hs b/src/server/SendMail.hs
index c649d59..74d48ab 100644
--- a/src/server/Mail.hs
+++ b/src/server/SendMail.hs
@@ -1,55 +1,42 @@
{-# LANGUAGE OverloadedStrings #-}
-module Mail
- ( Mail(..)
- , sendMail
+module SendMail
+ ( sendMail
) where
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
-import Data.Text.Lazy.Builder (toLazyText, fromText)
import Data.Either (isLeft)
import Control.Exception (SomeException, try)
+import Control.Arrow (left)
import qualified Network.Mail.Mime as M
-data Mail = Mail
- { to :: [Text]
- , subject :: Text
- , plainBody :: Text
- , htmlBody :: Text
- } deriving (Eq, Show)
+import Model.Mail
sendMail :: Mail -> IO (Either Text ())
sendMail mail = do
- result <- mapLeft (T.pack . show) <$> (try (M.renderSendMail . getMimeMail $ mail) :: IO (Either SomeException ()))
+ 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))
else return ()
return result
-mapLeft :: (a -> c) -> Either a b -> Either c b
-mapLeft f (Left l) = Left (f l)
-mapLeft _ (Right r) = (Right r)
-
getMimeMail :: Mail -> M.Mail
getMimeMail (Mail to subject plainBody htmlBody) =
let fromMail = M.emptyMail (address "no-reply@shared-cost.guyonvarch.me")
in fromMail
{ M.mailTo = map address to
, M.mailParts =
- [ [ M.plainPart . strictToLazy $ plainBody
- , M.htmlPart . strictToLazy $ htmlBody
+ [ [ M.plainPart plainBody
+ , M.htmlPart htmlBody
]
]
, M.mailHeaders = [("Subject", subject)]
}
-strictToLazy :: Text -> LT.Text
-strictToLazy = toLazyText . fromText
-
address :: Text -> M.Address
address addressEmail =
M.Address
diff --git a/src/server/View/Mail/SignIn.hs b/src/server/View/Mail/SignIn.hs
new file mode 100644
index 0000000..e11b876
--- /dev/null
+++ b/src/server/View/Mail/SignIn.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module View.Mail.SignIn
+ ( getMail
+ ) where
+
+import Data.Text (Text)
+import qualified Data.Text.Lazy as LT
+import Data.Text.Lazy.Builder (toLazyText, fromText)
+
+import Text.Blaze.Html
+import Text.Blaze.Html5
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+
+import Model.Database (User(..))
+import qualified Model.Mail as M
+
+getMail :: User -> Text -> [Text] -> M.Mail
+getMail user url to =
+ M.Mail
+ { M.to = to
+ , M.subject = "Sign in to Shared Cost"
+ , M.plainBody = plainBody user url
+ , M.htmlBody = htmlBody user url
+ }
+
+plainBody :: User -> Text -> LT.Text
+plainBody user url =
+ LT.intercalate
+ "\n"
+ [ LT.concat ["Hi ", strictToLazy . userName $ user, ","]
+ , ""
+ , "Click to the following link in order to sign in to Shared Cost:"
+ , strictToLazy url
+ ]
+
+htmlBody :: User -> Text -> LT.Text
+htmlBody user url =
+ renderHtml . docTypeHtml . body $ do
+ toHtml $ LT.concat ["Hi ", strictToLazy . userName $ user, ","]
+ br
+ br
+ "Click to the following link in order to sign in to Shared Cost:"
+ br
+ toHtml url
+
+strictToLazy :: Text -> LT.Text
+strictToLazy = toLazyText . fromText
diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs
index a397a96..5b9f06e 100644
--- a/src/server/View/Page.hs
+++ b/src/server/View/Page.hs
@@ -5,6 +5,7 @@ module View.Page
) where
import Data.Text.Internal.Lazy (Text)
+import Data.Text.Internal.Lazy as TL
import Text.Blaze.Html
import Text.Blaze.Html5
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-23 02:39:01 +0000