aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Application.hs43
-rw-r--r--src/server/Design/Color.hs3
-rw-r--r--src/server/Design/Global.hs22
-rw-r--r--src/server/Main.hs10
-rw-r--r--src/server/Model/Database.hs7
-rw-r--r--src/server/Model/Message.hs15
-rw-r--r--src/server/Model/Payment.hs6
-rw-r--r--src/server/Model/SignIn.hs34
-rw-r--r--src/server/Model/UUID.hs10
-rw-r--r--src/server/Model/User.hs6
10 files changed, 125 insertions, 31 deletions
diff --git a/src/server/Application.hs b/src/server/Application.hs
index 28ad3cd..75d0323 100644
--- a/src/server/Application.hs
+++ b/src/server/Application.hs
@@ -1,14 +1,15 @@
{-# LANGUAGE OverloadedStrings #-}
module Application
- ( signIn
- , signOut
+ ( signInAction
+ , validateSignInAction
+ , signOutAction
, getIndexAction
, getUsersAction
, getPaymentsAction
, addUserAction
, deleteUserAction
- , insertPaymentAction
+ , createPaymentAction
) where
import Web.Scotty
@@ -21,16 +22,17 @@ import Control.Monad.IO.Class (liftIO)
import Data.Text (Text)
import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
import Data.String (fromString)
-import qualified Data.Text.Lazy as TL
import qualified LoginSession
import qualified Secure
-import Model.Database (runDb)
+import Model.Database
import Model.User
import Model.Payment
+import Model.SignIn
import View.Page (page)
@@ -51,7 +53,7 @@ getPaymentsAction =
addUserAction :: Text -> Text -> ActionM ()
addUserAction email name = do
- _ <- liftIO . runDb $ insertUser email name
+ _ <- liftIO . runDb $ createUser email name
status ok200
deleteUserAction :: Text -> ActionM ()
@@ -59,28 +61,41 @@ deleteUserAction email = do
_ <- liftIO . runDb $ deleteUser email
status ok200
-insertPaymentAction :: Text -> Text -> Int -> ActionM ()
-insertPaymentAction email name cost = do
+createPaymentAction :: Text -> Text -> Int -> ActionM ()
+createPaymentAction email name cost = do
maybeUser <- liftIO . runDb $ getUser email
case maybeUser of
Just user -> do
- _ <- liftIO . runDb $ insertPayment (entityKey user) name cost
+ _ <- liftIO . runDb $ createPayment (entityKey user) name cost
return ()
Nothing -> do
status badRequest400
status ok200
-signIn :: Text -> ActionM ()
-signIn login = do
+signInAction :: Text -> ActionM ()
+signInAction login = do
maybeUser <- liftIO . runDb $ getUser login
case maybeUser of
Just _ -> do
- LoginSession.put login
+ token <- liftIO . runDb $ createSignInToken login
+ let url = T.concat ["http://localhost:3000/validateSignIn?token=", token]
+ liftIO . TIO.putStrLn $ url
status ok200
Nothing ->
status badRequest400
-signOut :: ActionM ()
-signOut = do
+validateSignInAction :: Text -> ActionM ()
+validateSignInAction token = do
+ maybeSignIn <- liftIO . runDb $ getSignInToken token
+ case maybeSignIn of
+ Just signIn -> do
+ LoginSession.put (signInEmail . entityVal $ signIn)
+ liftIO . runDb . signInTokenIsUsed . entityKey $ signIn
+ redirect "/"
+ Nothing ->
+ status badRequest400
+
+signOutAction :: ActionM ()
+signOutAction = do
LoginSession.delete
status ok200
diff --git a/src/server/Design/Color.hs b/src/server/Design/Color.hs
index 6344fe6..b744cf2 100644
--- a/src/server/Design/Color.hs
+++ b/src/server/Design/Color.hs
@@ -11,5 +11,8 @@ brown = C.brown
green :: C.Color
green = C.green
+grey :: C.Color
+grey = C.rgb 200 200 200
+
lightGrey :: C.Color
lightGrey = C.rgb 245 245 245
diff --git a/src/server/Design/Global.hs b/src/server/Design/Global.hs
index 7074f65..6e3cbe6 100644
--- a/src/server/Design/Global.hs
+++ b/src/server/Design/Global.hs
@@ -9,7 +9,6 @@ import Prelude
import Clay
-import Data.Monoid ((<>))
import Data.Text.Lazy (Text)
import Design.Color as C
@@ -23,8 +22,12 @@ iconFontSize = 32
global :: Css
global = do
+ input ? do
+ borderRadius (px 0) (px 0) (px 0) (px 0)
+ border solid (px 1) C.grey
+
header ? do
- let headerHeight = 120
+ let headerHeight = 150
h1 ? do
fontSize (px 40)
@@ -64,20 +67,23 @@ global = do
lineHeight (px 60)
nthChild "odd" & backgroundColor C.lightGrey
- form # ".signIn" ? do
+ ".signIn" ? do
let inputHeight = 50
- marginTop (px 80)
- marginBottom (px 80)
- width (pct 60)
+ width (px 500)
+ marginTop (px 50)
marginLeft auto
marginRight auto
input ? do
- width (pct 80)
+ display block
+ width (pct 100)
padding (px 10) (px 10) (px 10) (px 10)
height (px inputHeight)
+ marginBottom (px 10)
button ? do
- width (pct 20)
+ display block
+ width (pct 100)
height (px inputHeight)
backgroundColor C.brown
color C.white
borderWidth (px 0)
+ borderRadius (px 3) (px 3) (px 3) (px 3)
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 4461945..7fd42a7 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -23,10 +23,14 @@ main = do
post "/signIn" $ do
login <- param "login" :: ActionM Text
- signIn login
+ signInAction login
+
+ get "/validateSignIn" $ do
+ token <- param "token" :: ActionM Text
+ validateSignInAction token
post "/signOut" $
- signOut
+ signOutAction
get "/payments" $
getPaymentsAction
@@ -43,4 +47,4 @@ main = do
email <- param "email" :: ActionM Text
name <- param "name" :: ActionM Text
cost <- param "cost" :: ActionM Int
- insertPaymentAction email name cost
+ createPaymentAction email name cost
diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index abf235d..e5fd075 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -33,6 +33,13 @@ Payment
name Text
cost Int
deriving Show
+SignIn
+ token Text
+ creation UTCTime
+ email Text
+ isUsed Bool
+ UniqToken token
+ deriving Show
|]
type Persist a = SqlPersistT (ResourceT (NoLoggingT IO)) a
diff --git a/src/server/Model/Message.hs b/src/server/Model/Message.hs
new file mode 100644
index 0000000..acc785e
--- /dev/null
+++ b/src/server/Model/Message.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Message.Json
+ ( Message(..)
+ ) where
+
+import Data.Aeson
+import GHC.Generics
+
+data Message = Message
+ { message :: String
+ } deriving (Show, Generic)
+
+instance FromJSON Message
+instance ToJSON Message
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index b35e13c..ad1c261 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -1,6 +1,6 @@
module Model.Payment
( getPayments
- , insertPayment
+ , createPayment
) where
import Data.Text (Text)
@@ -30,7 +30,7 @@ getJsonPayment (paymentEntity, userEntity) =
in P.Payment (paymentCreation payment) (paymentName payment) (paymentCost payment) (userName user)
-insertPayment :: UserId -> Text -> Int -> Persist PaymentId
-insertPayment userId name cost = do
+createPayment :: UserId -> Text -> Int -> Persist PaymentId
+createPayment userId name cost = do
now <- liftIO getCurrentTime
insert $ Payment userId now name cost
diff --git a/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs
new file mode 100644
index 0000000..c447416
--- /dev/null
+++ b/src/server/Model/SignIn.hs
@@ -0,0 +1,34 @@
+module Model.SignIn
+ ( createSignInToken
+ , getSignInToken
+ , signInTokenIsUsed
+ ) where
+
+import Data.Text (Text)
+import Data.Time.Clock (getCurrentTime)
+
+import Control.Monad.IO.Class (liftIO)
+
+import Database.Persist
+
+import Model.Database
+import Model.UUID (generateUUID)
+
+createSignInToken :: Text -> Persist Text
+createSignInToken email = do
+ now <- liftIO getCurrentTime
+ token <- liftIO generateUUID
+ _ <- insert $ SignIn token now email False
+ return token
+
+getSignInToken :: Text -> Persist (Maybe (Entity SignIn))
+getSignInToken token =
+ selectFirst
+ [ SignInToken ==. token
+ , SignInIsUsed ==. False
+ ]
+ []
+
+signInTokenIsUsed :: SignInId -> Persist ()
+signInTokenIsUsed tokenId =
+ update tokenId [SignInIsUsed =. True]
diff --git a/src/server/Model/UUID.hs b/src/server/Model/UUID.hs
new file mode 100644
index 0000000..6cb7ce0
--- /dev/null
+++ b/src/server/Model/UUID.hs
@@ -0,0 +1,10 @@
+module Model.UUID
+ ( generateUUID
+ ) where
+
+import Data.UUID (toString)
+import Data.UUID.V4 (nextRandom)
+import Data.Text (Text, pack)
+
+generateUUID :: IO Text
+generateUUID = pack . toString <$> nextRandom
diff --git a/src/server/Model/User.hs b/src/server/Model/User.hs
index ddca0fb..339aff6 100644
--- a/src/server/Model/User.hs
+++ b/src/server/Model/User.hs
@@ -1,7 +1,7 @@
module Model.User
( getUsers
, getUser
- , insertUser
+ , createUser
, deleteUser
) where
@@ -20,8 +20,8 @@ getUsers = map entityVal <$> selectList [] [Desc UserCreation]
getUser :: Text -> Persist (Maybe (Entity User))
getUser email = selectFirst [UserEmail ==. email] []
-insertUser :: Text -> Text -> Persist UserId
-insertUser email name = do
+createUser :: Text -> Text -> Persist UserId
+createUser email name = do
now <- liftIO getCurrentTime
insert $ User now email name
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-24 01:39:22 +0000