aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--elm-package.json6
-rwxr-xr-xgen2
-rw-r--r--sharedCost.cabal (renamed from payments.cabal)7
-rw-r--r--src/client/Model/View.elm3
-rw-r--r--src/client/Model/View/SignIn.elm15
-rw-r--r--src/client/Update.elm15
-rw-r--r--src/client/Update/SignIn.elm15
-rw-r--r--src/client/View/Page.elm22
-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
18 files changed, 192 insertions, 49 deletions
diff --git a/elm-package.json b/elm-package.json
index e975976..a520a22 100644
--- a/elm-package.json
+++ b/elm-package.json
@@ -1,11 +1,11 @@
{
"version": "0.0.1",
- "summary": "Payments",
- "repository": "https://github.com/guyonvarch/payments.git",
+ "summary": "SharedCost",
+ "repository": "https://github.com/guyonvarch/sharedCost.git",
"license": "BSD3",
"source-directories": ["src/client"],
"exposed-modules": ["Main"],
- "elm-version": "0.15.0 <= v < 0.16.0",
+ "elm-version": "0.15.1 <= v < 0.16.0",
"dependencies": {
"elm-lang/core": "2.0.1 <= v < 3.0.0",
"evancz/elm-html": "3.0.0 <= v < 4.0.0",
diff --git a/gen b/gen
index 28a2d2b..5e5358d 100755
--- a/gen
+++ b/gen
@@ -2,4 +2,4 @@
trap 'fuser -k 3000/tcp' EXIT
elm-make src/client/Main.elm --output public/javascripts/client.js \
&& cabal build \
- && ./dist/build/payments/payments
+ && ./dist/build/sharedCost/sharedCost
diff --git a/payments.cabal b/sharedCost.cabal
index 0e39dbc..1ccddc5 100644
--- a/payments.cabal
+++ b/sharedCost.cabal
@@ -1,12 +1,12 @@
-name: Payments
+name: SharedCost
version: 0.0.1
-homepage: https://github.com/guyonvarch/payments
+homepage: https://github.com/guyonvarch/sharedCost
author: Joris Guyonvarch
category: Web
build-type: Simple
cabal-version: >= 1.8
-executable payments
+executable sharedCost
main-is: Main.hs
hs-source-dirs: src/server
ghc-options: -Wall -fwarn-incomplete-uni-patterns
@@ -28,3 +28,4 @@ executable payments
, aeson == 0.9.0.1
, scotty-cookie == 0.1.0.3
, clientsession == 0.9.1.1
+ , uuid == 1.3.10
diff --git a/src/client/Model/View.elm b/src/client/Model/View.elm
index ca819e3..3e3cbca 100644
--- a/src/client/Model/View.elm
+++ b/src/client/Model/View.elm
@@ -3,8 +3,9 @@ module Model.View
) where
import Model.Payment exposing (Payments)
+import Model.View.SignIn exposing (..)
type View =
LoadingView
| PaymentView Payments
- | SignInView String
+ | SignInView SignIn
diff --git a/src/client/Model/View/SignIn.elm b/src/client/Model/View/SignIn.elm
new file mode 100644
index 0000000..1c8eae7
--- /dev/null
+++ b/src/client/Model/View/SignIn.elm
@@ -0,0 +1,15 @@
+module Model.View.SignIn
+ ( SignIn
+ , initSignIn
+ ) where
+
+type alias SignIn =
+ { login : String
+ , authentication : Maybe (Result String String)
+ }
+
+initSignIn : SignIn
+initSignIn =
+ { login = ""
+ , authentication = Nothing
+ }
diff --git a/src/client/Update.elm b/src/client/Update.elm
index 3937888..1d0fe95 100644
--- a/src/client/Update.elm
+++ b/src/client/Update.elm
@@ -7,11 +7,14 @@ module Update
import Model exposing (Model)
import Model.Payment exposing (Payments)
import Model.View exposing (..)
+import Model.View.SignIn exposing (..)
+
+import Update.SignIn exposing (..)
type Action =
NoOp
| SignIn
- | UpdateLogin String
+ | UpdateSignIn SignInAction
| UpdatePayments Payments
actions : Signal.Mailbox Action
@@ -23,8 +26,12 @@ updateModel action model =
NoOp ->
model
SignIn ->
- { model | view <- SignInView "" }
- UpdateLogin login ->
- { model | view <- SignInView login }
+ { model | view <- SignInView initSignIn }
+ UpdateSignIn signInAction ->
+ case model.view of
+ SignInView signIn ->
+ { model | view <- SignInView (updateSignIn signInAction signIn) }
+ _ ->
+ model
UpdatePayments payments ->
{ model | view <- PaymentView payments }
diff --git a/src/client/Update/SignIn.elm b/src/client/Update/SignIn.elm
new file mode 100644
index 0000000..a962f90
--- /dev/null
+++ b/src/client/Update/SignIn.elm
@@ -0,0 +1,15 @@
+module Update.SignIn
+ ( SignInAction(..)
+ , updateSignIn
+ ) where
+
+import Model.View.SignIn exposing (..)
+
+type SignInAction =
+ UpdateLogin String
+
+updateSignIn : SignInAction -> SignIn -> SignIn
+updateSignIn action signIn =
+ case action of
+ UpdateLogin login ->
+ { signIn | login <- login }
diff --git a/src/client/View/Page.elm b/src/client/View/Page.elm
index 1683cf3..eb86132 100644
--- a/src/client/View/Page.elm
+++ b/src/client/View/Page.elm
@@ -13,11 +13,14 @@ import Date exposing (Date)
import String exposing (append)
+import Json.Decode as Json
+
import Model exposing (Model)
import Model.Payment exposing (Payments, Payment)
import Model.View exposing (..)
import Update exposing (..)
+import Update.SignIn exposing (..)
import ServerCommunication as SC
import ServerCommunication exposing (serverCommunications)
@@ -38,7 +41,7 @@ renderHeader model =
[]
[ h1
[]
- [ text "Payments" ]
+ [ text "Shared Cost" ]
, case model.view of
LoadingView ->
text ""
@@ -57,7 +60,7 @@ renderMain model =
case model.view of
LoadingView ->
loadingView
- SignInView login ->
+ SignInView { login } ->
signInView login
PaymentView payments ->
paymentsView payments
@@ -67,18 +70,25 @@ loadingView = text ""
signInView : String -> Html
signInView login =
- H.form
+ div
[ class "signIn" ]
[ input
[ value login
- , on "input" targetValue (Signal.message actions.address << UpdateLogin)
+ , on "input" targetValue (Signal.message actions.address << UpdateSignIn << UpdateLogin)
+ , onEnter serverCommunications.address (SC.SignIn login)
]
[]
, button
[ onClick serverCommunications.address (SC.SignIn login) ]
- [ renderIcon "sign-in" ]
+ [ text "Sign in" ]
]
+onEnter : Signal.Address a -> a -> Attribute
+onEnter address value =
+ on "keydown"
+ (Json.customDecoder keyCode (\code -> if code == 13 then Ok () else Err ""))
+ (\_ -> Signal.message address value)
+
paymentsView : Payments -> Html
paymentsView payments =
table
@@ -112,5 +122,5 @@ paymentLine payment =
renderDate : Date -> String
renderDate date =
toString (Date.day date)
- |> flip append (" " ++ (toString (Date.month date)))
+ |> flip append (" " ++ (toString (Date.month date)) ++ ".")
|> flip append (" " ++ (toString (Date.year date)))
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-22 20:10:44 +0000