aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/client/Main.elm101
-rw-r--r--src/client/ServerCommunication.elm143
-rw-r--r--src/client/elm/InitViewAction.elm25
-rw-r--r--src/client/elm/Main.elm89
-rw-r--r--src/client/elm/Model.elm (renamed from src/client/Model.elm)0
-rw-r--r--src/client/elm/Model/Config.elm (renamed from src/client/Model/Config.elm)0
-rw-r--r--src/client/elm/Model/Date.elm (renamed from src/client/Model/Date.elm)0
-rw-r--r--src/client/elm/Model/Income.elm (renamed from src/client/Model/Income.elm)0
-rw-r--r--src/client/elm/Model/Payer.elm (renamed from src/client/Model/Payer.elm)0
-rw-r--r--src/client/elm/Model/Payment.elm (renamed from src/client/Model/Payment.elm)0
-rw-r--r--src/client/elm/Model/Translations.elm (renamed from src/client/Model/Translations.elm)0
-rw-r--r--src/client/elm/Model/User.elm (renamed from src/client/Model/User.elm)0
-rw-r--r--src/client/elm/Model/View.elm (renamed from src/client/Model/View.elm)0
-rw-r--r--src/client/elm/Model/View/LoggedIn/Account.elm (renamed from src/client/Model/View/LoggedIn/Account.elm)0
-rw-r--r--src/client/elm/Model/View/LoggedIn/Add.elm (renamed from src/client/Model/View/LoggedIn/Add.elm)0
-rw-r--r--src/client/elm/Model/View/LoggedIn/Edition.elm (renamed from src/client/Model/View/LoggedIn/Edition.elm)0
-rw-r--r--src/client/elm/Model/View/LoggedIn/Monthly.elm (renamed from src/client/Model/View/LoggedIn/Monthly.elm)0
-rw-r--r--src/client/elm/Model/View/LoggedInView.elm (renamed from src/client/Model/View/LoggedInView.elm)0
-rw-r--r--src/client/elm/Model/View/SignInView.elm (renamed from src/client/Model/View/SignInView.elm)0
-rw-r--r--src/client/elm/Native/Reads.js (renamed from src/client/Native/Reads.js)0
-rw-r--r--src/client/elm/Persona.elm28
-rw-r--r--src/client/elm/Reads.elm (renamed from src/client/Reads.elm)0
-rw-r--r--src/client/elm/ServerCommunication.elm95
-rw-r--r--src/client/elm/Sign.elm43
-rw-r--r--src/client/elm/SimpleHTTP.elm41
-rw-r--r--src/client/elm/Update.elm (renamed from src/client/Update.elm)0
-rw-r--r--src/client/elm/Update/LoggedIn.elm (renamed from src/client/Update/LoggedIn.elm)0
-rw-r--r--src/client/elm/Update/LoggedIn/Account.elm (renamed from src/client/Update/LoggedIn/Account.elm)0
-rw-r--r--src/client/elm/Update/LoggedIn/Add.elm (renamed from src/client/Update/LoggedIn/Add.elm)0
-rw-r--r--src/client/elm/Update/LoggedIn/Monthly.elm (renamed from src/client/Update/LoggedIn/Monthly.elm)0
-rw-r--r--src/client/elm/Update/SignIn.elm (renamed from src/client/Update/SignIn.elm)11
-rw-r--r--src/client/elm/Utils/Dict.elm (renamed from src/client/Utils/Dict.elm)0
-rw-r--r--src/client/elm/Utils/Either.elm (renamed from src/client/Utils/Either.elm)0
-rw-r--r--src/client/elm/Utils/Maybe.elm (renamed from src/client/Utils/Maybe.elm)0
-rw-r--r--src/client/elm/Utils/Validation.elm (renamed from src/client/Utils/Validation.elm)0
-rw-r--r--src/client/elm/View/Date.elm (renamed from src/client/View/Date.elm)0
-rw-r--r--src/client/elm/View/Events.elm (renamed from src/client/View/Events.elm)0
-rw-r--r--src/client/elm/View/Expand.elm (renamed from src/client/View/Expand.elm)0
-rw-r--r--src/client/elm/View/Header.elm (renamed from src/client/View/Header.elm)15
-rw-r--r--src/client/elm/View/Icon.elm (renamed from src/client/View/Icon.elm)0
-rw-r--r--src/client/elm/View/Loading.elm (renamed from src/client/View/Loading.elm)0
-rw-r--r--src/client/elm/View/LoggedIn.elm (renamed from src/client/View/LoggedIn.elm)0
-rw-r--r--src/client/elm/View/LoggedIn/Account.elm (renamed from src/client/View/LoggedIn/Account.elm)0
-rw-r--r--src/client/elm/View/LoggedIn/Add.elm (renamed from src/client/View/LoggedIn/Add.elm)0
-rw-r--r--src/client/elm/View/LoggedIn/Monthly.elm (renamed from src/client/View/LoggedIn/Monthly.elm)0
-rw-r--r--src/client/elm/View/LoggedIn/Paging.elm (renamed from src/client/View/LoggedIn/Paging.elm)0
-rw-r--r--src/client/elm/View/LoggedIn/Table.elm (renamed from src/client/View/LoggedIn/Table.elm)0
-rw-r--r--src/client/elm/View/Page.elm (renamed from src/client/View/Page.elm)0
-rw-r--r--src/client/elm/View/Price.elm (renamed from src/client/View/Price.elm)0
-rw-r--r--src/client/elm/View/SignIn.elm (renamed from src/client/View/SignIn.elm)13
-rw-r--r--src/client/js/main.js28
-rw-r--r--src/server/Config.hs2
-rw-r--r--src/server/Controller/SignIn.hs84
-rw-r--r--src/server/Design/Header.hs2
-rw-r--r--src/server/Design/SignIn.hs20
-rw-r--r--src/server/Main.hs12
-rw-r--r--src/server/Model/Database.hs1
-rw-r--r--src/server/Model/Message/Key.hs6
-rw-r--r--src/server/Model/Message/Translations.hs26
-rw-r--r--src/server/Model/SignIn.hs17
-rw-r--r--src/server/Persona.hs42
-rw-r--r--src/server/Secure.hs7
-rw-r--r--src/server/View/Page.hs4
63 files changed, 431 insertions, 424 deletions
diff --git a/src/client/Main.elm b/src/client/Main.elm
deleted file mode 100644
index 4f96675..0000000
--- a/src/client/Main.elm
+++ /dev/null
@@ -1,101 +0,0 @@
-module Main
- ( main
- ) where
-
-import Graphics.Element exposing (..)
-
-import Html exposing (Html)
-
-import Http
-import Task exposing (..)
-import Time exposing (..)
-import Json.Decode as Json exposing ((:=))
-import Dict
-
-import Model exposing (Model, initialModel)
-import Model.User exposing (Users, usersDecoder, UserId, userIdDecoder)
-import Model.Payment exposing (Payments, paymentsDecoder, perPage)
-import Model.Payer exposing (Payers, payersDecoder)
-import Model.Translations exposing (..)
-import Model.Config exposing (..)
-
-import Update exposing (Action(..), actions, updateModel)
-import Update.SignIn exposing (..)
-
-import View.Page exposing (renderPage)
-
-import ServerCommunication exposing (serverCommunications, sendRequest)
-
-main : Signal Html
-main = Signal.map renderPage model
-
-model : Signal Model
-model = Signal.foldp updateModel (initialModel initialTime translations config) update
-
-update : Signal Action
-update = Signal.mergeMany
- [ Signal.map UpdateTime (Time.every 1000)
- , actions.signal
- ]
-
----------------------------------------
-
-port signInError : Maybe String
-
----------------------------------------
-
-port initialTime : Time
-
----------------------------------------
-
-port translations : String
-
----------------------------------------
-
-port config : String
-
----------------------------------------
-
-port initView : Task Http.Error ()
-port initView =
- case signInError of
- Just msg ->
- Signal.send actions.address (SignInError msg)
- Nothing ->
- Task.onError goLoggedInView (\_ -> Signal.send actions.address GoSignInView)
-
-goLoggedInView : Task Http.Error ()
-goLoggedInView =
- Task.andThen getUsers <| \users ->
- Task.andThen whoAmI <| \me ->
- Task.andThen getMonthlyPayments <| \monthlyPayments ->
- Task.andThen getPayments <| \payments ->
- Task.andThen getPaymentsCount <| \paymentsCount ->
- Task.andThen getPayers <| \payers ->
- Signal.send actions.address (GoLoggedInView users me monthlyPayments payments paymentsCount payers)
-
-getUsers : Task Http.Error Users
-getUsers = Http.get usersDecoder "/users"
-
-whoAmI : Task Http.Error UserId
-whoAmI = Http.get ("id" := userIdDecoder) "/whoAmI"
-
-getMonthlyPayments : Task Http.Error Payments
-getMonthlyPayments = Http.get paymentsDecoder "/monthlyPayments"
-
-getPayments : Task Http.Error Payments
-getPayments = Http.get paymentsDecoder ("/payments?page=1&perPage=" ++ toString perPage)
-
-getPaymentsCount : Task Http.Error Int
-getPaymentsCount = Http.get ("number" := Json.int) "/payments/count"
-
-getPayers : Task Http.Error Payers
-getPayers = Http.get payersDecoder "/payers"
-
----------------------------------------
-
-port serverCommunicationsPort : Signal (Task Http.RawError ())
-port serverCommunicationsPort =
- Signal.map
- (\comm -> sendRequest comm `Task.andThen` (Signal.send actions.address))
- serverCommunications.signal
diff --git a/src/client/ServerCommunication.elm b/src/client/ServerCommunication.elm
deleted file mode 100644
index 55bf947..0000000
--- a/src/client/ServerCommunication.elm
+++ /dev/null
@@ -1,143 +0,0 @@
-module ServerCommunication
- ( Communication(..)
- , sendRequest
- , serverCommunications
- ) where
-
-import Signal
-import Task as Task exposing (Task)
-import Http
-import Json.Decode exposing (..)
-import Date
-import Time exposing (Time)
-
-import Model.User exposing (UserId)
-import Model.Payment exposing (..)
-import Model.View.LoggedIn.Add exposing (Frequency(..))
-
-import Update as U
-import Update.SignIn exposing (..)
-import Update.LoggedIn as UL
-import Update.LoggedIn.Monthly as UM
-import Update.LoggedIn.Account as UA
-
-type Communication =
- NoCommunication
- | SignIn String
- | AddPayment UserId String Int
- | AddMonthlyPayment String Int
- | SetIncome Time Int
- | DeletePayment Payment Int
- | DeleteMonthlyPayment PaymentId
- | UpdatePage Int
- | SignOut
-
-serverCommunications : Signal.Mailbox Communication
-serverCommunications = Signal.mailbox NoCommunication
-
-sendRequest : Communication -> Task Http.RawError U.Action
-sendRequest communication =
- case getRequest communication of
- Nothing ->
- Task.succeed U.NoOp
- Just request ->
- Http.send Http.defaultSettings request
- |> flip Task.andThen (serverResult communication)
-
-getRequest : Communication -> Maybe Http.Request
-getRequest communication =
- case communication of
- NoCommunication -> Nothing
- SignIn login -> Just (simple "post" ("/signIn?login=" ++ login))
- AddPayment userId name cost -> Just (addPaymentRequest name cost Punctual)
- AddMonthlyPayment name cost -> Just (addPaymentRequest name cost Monthly)
- SetIncome _ amount -> Just (simple "post" ("/income?amount=" ++ (toString amount)))
- DeletePayment payment _ -> Just (deletePaymentRequest payment.id)
- DeleteMonthlyPayment paymentId -> Just (deletePaymentRequest paymentId)
- UpdatePage page -> Just (updatePageRequest page)
- SignOut -> Just (simple "post" "/signOut")
-
-addPaymentRequest : String -> Int -> Frequency -> Http.Request
-addPaymentRequest name cost frequency =
- simple "post" ("/payment/add?name=" ++ name ++ "&cost=" ++ (toString cost) ++ "&frequency=" ++ (toString frequency))
-
-deletePaymentRequest : PaymentId -> Http.Request
-deletePaymentRequest id =
- simple "post" ("payment/delete?id=" ++ (toString id))
-
-updatePageRequest : Int -> Http.Request
-updatePageRequest page =
- simple "get" ("payments?page=" ++ toString page ++ "&perPage=" ++ toString perPage)
-
-simple : String -> String -> Http.Request
-simple method url =
- { verb = method
- , headers = []
- , url = url
- , body = Http.empty
- }
-
-serverResult : Communication -> Http.Response -> Task Http.RawError U.Action
-serverResult communication response =
- case response.status of
- 200 ->
- case communication of
- NoCommunication ->
- Task.succeed U.NoOp
- SignIn login ->
- Task.succeed << U.UpdateSignIn <| ValidLogin login
- AddPayment userId name cost ->
- Http.send Http.defaultSettings (updatePageRequest 1)
- |> flip Task.andThen (decodeOkResponse paymentsDecoder (\payments ->
- Task.succeed <| U.UpdateLoggedIn (UL.AddPayment userId name cost payments)
- ))
- AddMonthlyPayment name cost ->
- decodeResponse
- ("id" := paymentIdDecoder)
- (\id -> Task.succeed <| U.UpdateLoggedIn (UL.AddMonthlyPayment id name cost))
- response
- SetIncome currentTime amount ->
- Task.succeed <| U.UpdateLoggedIn (UL.UpdateAccount (UA.UpdateIncome currentTime amount))
- DeletePayment payment currentPage ->
- Http.send Http.defaultSettings (updatePageRequest currentPage)
- |> flip Task.andThen (decodeOkResponse paymentsDecoder (\payments ->
- Task.succeed <| U.UpdateLoggedIn (UL.DeletePayment payment payments)
- ))
- DeleteMonthlyPayment id ->
- Task.succeed <| U.UpdateLoggedIn (UL.UpdateMonthly (UM.DeletePayment id))
- UpdatePage page ->
- decodeResponse
- paymentsDecoder
- (\payments -> Task.succeed <| U.UpdateLoggedIn (UL.UpdatePage page payments))
- response
- SignOut ->
- Task.succeed (U.GoSignInView)
- errorStatus ->
- case communication of
- SignIn _ ->
- decodeResponse
- ("error" := string)
- (\error ->
- Task.succeed <| U.UpdateSignIn (ErrorLogin error)
- )
- response
- _ ->
- Task.succeed <| U.NoOp
-
-decodeOkResponse : Decoder a -> (a -> Task b U.Action) -> Http.Response -> Task b U.Action
-decodeOkResponse decoder responseToAction response =
- if response.status == 200
- then decodeResponse decoder responseToAction response
- else Task.succeed U.NoOp
-
-decodeResponse : Decoder a -> (a -> Task b U.Action) -> Http.Response -> Task b U.Action
-decodeResponse decoder responseToAction response =
- case response.value of
- Http.Text text ->
- case decodeString decoder text of
- Ok x ->
- responseToAction x
- Err _ ->
- Task.succeed U.NoOp
- Http.Blob _ ->
- Task.succeed U.NoOp
diff --git a/src/client/elm/InitViewAction.elm b/src/client/elm/InitViewAction.elm
new file mode 100644
index 0000000..7c353a7
--- /dev/null
+++ b/src/client/elm/InitViewAction.elm
@@ -0,0 +1,25 @@
+module InitViewAction
+ ( initViewAction
+ ) where
+
+import Task exposing (..)
+import Http
+import Json.Decode as Json exposing ((:=))
+
+import Update exposing (Action(GoLoggedInView, GoSignInView))
+
+import Model.Payment exposing (Payments, paymentsDecoder, perPage)
+import Model.Payer exposing (Payers, payersDecoder)
+import Model.User exposing (Users, usersDecoder, UserId, userIdDecoder)
+
+initViewAction : Task Http.Error Action
+initViewAction = Task.onError loggedInView (always <| Task.succeed GoSignInView)
+
+loggedInView : Task Http.Error Action
+loggedInView =
+ Task.map GoLoggedInView (Http.get usersDecoder "/users")
+ `Task.andMap` (Http.get ("id" := userIdDecoder) "/whoAmI")
+ `Task.andMap` (Http.get paymentsDecoder "/monthlyPayments")
+ `Task.andMap` (Http.get paymentsDecoder ("/payments?page=1&perPage=" ++ toString perPage))
+ `Task.andMap` (Http.get ("number" := Json.int) "/payments/count")
+ `Task.andMap` (Http.get payersDecoder "/payers")
diff --git a/src/client/elm/Main.elm b/src/client/elm/Main.elm
new file mode 100644
index 0000000..f79d6a0
--- /dev/null
+++ b/src/client/elm/Main.elm
@@ -0,0 +1,89 @@
+module Main
+ ( main
+ ) where
+
+import Graphics.Element exposing (..)
+
+import Html exposing (Html)
+
+import Http
+import Task exposing (..)
+import Time exposing (..)
+import Json.Decode as Json
+import Dict
+import String
+
+import Model exposing (Model, initialModel)
+import Model.Translations exposing (..)
+import Model.Config exposing (..)
+
+import Update exposing (Action(..), actions, updateModel)
+import Update.SignIn exposing (..)
+
+import View.Page exposing (renderPage)
+
+import ServerCommunication as SC exposing (serverCommunications, sendRequest)
+
+import Persona as Persona exposing (operations)
+
+import InitViewAction exposing (initViewAction)
+
+import Sign
+
+main : Signal Html
+main = Signal.map renderPage model
+
+model : Signal Model
+model = Signal.foldp updateModel (initialModel initialTime translations config) update
+
+update : Signal Action
+update = Signal.mergeMany
+ [ Signal.map UpdateTime (Time.every 1000)
+ , actions.signal
+ ]
+
+---------------------------------------
+
+port initialTime : Time
+
+---------------------------------------
+
+port translations : String
+
+---------------------------------------
+
+port config : String
+
+---------------------------------------
+
+port ready : Signal String
+port ready = Signal.constant "ready"
+
+---------------------------------------
+
+port initView : Task Http.Error ()
+port initView = initViewAction `Task.andThen` (Signal.send actions.address)
+
+---------------------------------------
+
+port serverCommunicationsPort : Signal (Task Http.Error ())
+port serverCommunicationsPort =
+ Signal.map
+ (\comm ->
+ sendRequest comm
+ |> flip Task.andThen (\action -> Signal.send actions.address action)
+ )
+ (Signal.merge signCommunication serverCommunications.signal)
+
+---------------------------------------
+
+port persona : Signal String
+port persona = Signal.map Persona.toString operations.signal
+
+---------------------------------------
+
+port sign : Signal Json.Value
+
+signCommunication : Signal SC.Communication
+signCommunication =
+ Signal.map (Sign.toServerCommunication << Sign.decodeOperation) sign
diff --git a/src/client/Model.elm b/src/client/elm/Model.elm
index 43a19c5..43a19c5 100644
--- a/src/client/Model.elm
+++ b/src/client/elm/Model.elm
diff --git a/src/client/Model/Config.elm b/src/client/elm/Model/Config.elm
index e47b032..e47b032 100644
--- a/src/client/Model/Config.elm
+++ b/src/client/elm/Model/Config.elm
diff --git a/src/client/Model/Date.elm b/src/client/elm/Model/Date.elm
index 1c56de4..1c56de4 100644
--- a/src/client/Model/Date.elm
+++ b/src/client/elm/Model/Date.elm
diff --git a/src/client/Model/Income.elm b/src/client/elm/Model/Income.elm
index 97a5652..97a5652 100644
--- a/src/client/Model/Income.elm
+++ b/src/client/elm/Model/Income.elm
diff --git a/src/client/Model/Payer.elm b/src/client/elm/Model/Payer.elm
index 9fd1bb5..9fd1bb5 100644
--- a/src/client/Model/Payer.elm
+++ b/src/client/elm/Model/Payer.elm
diff --git a/src/client/Model/Payment.elm b/src/client/elm/Model/Payment.elm
index c4a8963..c4a8963 100644
--- a/src/client/Model/Payment.elm
+++ b/src/client/elm/Model/Payment.elm
diff --git a/src/client/Model/Translations.elm b/src/client/elm/Model/Translations.elm
index bec8c9b..bec8c9b 100644
--- a/src/client/Model/Translations.elm
+++ b/src/client/elm/Model/Translations.elm
diff --git a/src/client/Model/User.elm b/src/client/elm/Model/User.elm
index 1412913..1412913 100644
--- a/src/client/Model/User.elm
+++ b/src/client/elm/Model/User.elm
diff --git a/src/client/Model/View.elm b/src/client/elm/Model/View.elm
index 90c0e53..90c0e53 100644
--- a/src/client/Model/View.elm
+++ b/src/client/elm/Model/View.elm
diff --git a/src/client/Model/View/LoggedIn/Account.elm b/src/client/elm/Model/View/LoggedIn/Account.elm
index 2bb3ae7..2bb3ae7 100644
--- a/src/client/Model/View/LoggedIn/Account.elm
+++ b/src/client/elm/Model/View/LoggedIn/Account.elm
diff --git a/src/client/Model/View/LoggedIn/Add.elm b/src/client/elm/Model/View/LoggedIn/Add.elm
index 5598084..5598084 100644
--- a/src/client/Model/View/LoggedIn/Add.elm
+++ b/src/client/elm/Model/View/LoggedIn/Add.elm
diff --git a/src/client/Model/View/LoggedIn/Edition.elm b/src/client/elm/Model/View/LoggedIn/Edition.elm
index da6d7b0..da6d7b0 100644
--- a/src/client/Model/View/LoggedIn/Edition.elm
+++ b/src/client/elm/Model/View/LoggedIn/Edition.elm
diff --git a/src/client/Model/View/LoggedIn/Monthly.elm b/src/client/elm/Model/View/LoggedIn/Monthly.elm
index 3c6f66a..3c6f66a 100644
--- a/src/client/Model/View/LoggedIn/Monthly.elm
+++ b/src/client/elm/Model/View/LoggedIn/Monthly.elm
diff --git a/src/client/Model/View/LoggedInView.elm b/src/client/elm/Model/View/LoggedInView.elm
index 122c4be..122c4be 100644
--- a/src/client/Model/View/LoggedInView.elm
+++ b/src/client/elm/Model/View/LoggedInView.elm
diff --git a/src/client/Model/View/SignInView.elm b/src/client/elm/Model/View/SignInView.elm
index 0fbce39..0fbce39 100644
--- a/src/client/Model/View/SignInView.elm
+++ b/src/client/elm/Model/View/SignInView.elm
diff --git a/src/client/Native/Reads.js b/src/client/elm/Native/Reads.js
index 5785aed..5785aed 100644
--- a/src/client/Native/Reads.js
+++ b/src/client/elm/Native/Reads.js
diff --git a/src/client/elm/Persona.elm b/src/client/elm/Persona.elm
new file mode 100644
index 0000000..51b5fc6
--- /dev/null
+++ b/src/client/elm/Persona.elm
@@ -0,0 +1,28 @@
+module Persona
+ ( Operation(..)
+ , operations
+ , fromString
+ , toString
+ ) where
+
+type Operation =
+ NoOp
+ | SignIn
+ | SignOut
+
+operations : Signal.Mailbox Operation
+operations = Signal.mailbox NoOp
+
+fromString : String -> Operation
+fromString str =
+ case str of
+ "SignIn" -> SignIn
+ "SignOut" -> SignOut
+ _ -> NoOp
+
+toString : Operation -> String
+toString operation =
+ case operation of
+ SignIn -> "SignIn"
+ SignOut -> "SignOut"
+ _ -> "NoOp"
diff --git a/src/client/Reads.elm b/src/client/elm/Reads.elm
index f855802..f855802 100644
--- a/src/client/Reads.elm
+++ b/src/client/elm/Reads.elm
diff --git a/src/client/elm/ServerCommunication.elm b/src/client/elm/ServerCommunication.elm
new file mode 100644
index 0000000..70612cb
--- /dev/null
+++ b/src/client/elm/ServerCommunication.elm
@@ -0,0 +1,95 @@
+module ServerCommunication
+ ( Communication(..)
+ , sendRequest
+ , serverCommunications
+ ) where
+
+import Signal
+import Task as Task exposing (Task)
+import Http
+import Json.Decode exposing (..)
+import Date
+import Time exposing (Time)
+import Debug
+
+import SimpleHTTP exposing (..)
+
+import Model.User exposing (UserId)
+import Model.Payment exposing (..)
+import Model.View.LoggedIn.Add exposing (Frequency(..))
+
+import Update as U
+import Update.SignIn exposing (..)
+import Update.LoggedIn as UL
+import Update.LoggedIn.Monthly as UM
+import Update.LoggedIn.Account as UA
+
+import InitViewAction exposing (initViewAction)
+
+type Communication =
+ NoCommunication
+ | SignIn String
+ | AddPayment UserId String Int
+ | AddMonthlyPayment String Int
+ | SetIncome Time Int
+ | DeletePayment Payment Int
+ | DeleteMonthlyPayment PaymentId
+ | UpdatePage Int
+ | SignOut
+
+serverCommunications : Signal.Mailbox Communication
+serverCommunications = Signal.mailbox NoCommunication
+
+sendRequest : Communication -> Task Http.Error U.Action
+sendRequest communication =
+ case communication of
+
+ NoCommunication ->
+ Task.succeed U.NoOp
+
+ SignIn assertion ->
+ post ("/signIn?assertion=" ++ assertion)
+ |> flip Task.andThen (always initViewAction)
+
+ AddPayment userId name cost ->
+ post (addPaymentURL name cost Punctual)
+ |> flip Task.andThen (always (getPaymentsAtPage 1))
+ |> Task.map (\payments -> U.UpdateLoggedIn (UL.AddPayment userId name cost payments))
+
+ AddMonthlyPayment name cost ->
+ post (addPaymentURL name cost Monthly)
+ |> flip Task.andThen (decodeHttpValue <| "id" := paymentIdDecoder)
+ |> Task.map (\id -> U.UpdateLoggedIn (UL.AddMonthlyPayment id name cost))
+
+ DeletePayment payment currentPage ->
+ post (deletePaymentURL payment.id)
+ |> flip Task.andThen (always (getPaymentsAtPage currentPage))
+ |> Task.map (\payments -> U.UpdateLoggedIn (UL.DeletePayment payment payments))
+
+ DeleteMonthlyPayment id ->
+ post (deletePaymentURL id)
+ |> Task.map (always (U.UpdateLoggedIn (UL.UpdateMonthly (UM.DeletePayment id))))
+
+ UpdatePage page ->
+ getPaymentsAtPage page
+ |> flip Task.andThen (Task.succeed << U.UpdateLoggedIn << UL.UpdatePage page)
+
+ SetIncome currentTime amount ->
+ post ("/income?amount=" ++ (toString amount))
+ |> Task.map (always (U.UpdateLoggedIn (UL.UpdateAccount (UA.UpdateIncome currentTime amount))))
+
+ SignOut ->
+ post "/signOut"
+ |> Task.map (always U.GoSignInView)
+
+getPaymentsAtPage : Int -> Task Http.Error Payments
+getPaymentsAtPage page =
+ Http.get paymentsDecoder ("payments?page=" ++ toString page ++ "&perPage=" ++ toString perPage)
+
+addPaymentURL : String -> Int -> Frequency -> String
+addPaymentURL name cost frequency =
+ "/payment/add?name=" ++ name ++ "&cost=" ++ (toString cost) ++ "&frequency=" ++ (toString frequency)
+
+deletePaymentURL : PaymentId -> String
+deletePaymentURL id =
+ "payment/delete?id=" ++ (toString id)
diff --git a/src/client/elm/Sign.elm b/src/client/elm/Sign.elm
new file mode 100644
index 0000000..44f23b8
--- /dev/null
+++ b/src/client/elm/Sign.elm
@@ -0,0 +1,43 @@
+module Sign
+ ( Operation(..)
+ , decodeOperation
+ , toServerCommunication
+ ) where
+
+import Json.Decode as Json
+import Json.Decode exposing (Value, Decoder, (:=))
+import Maybe
+
+import ServerCommunication as SC
+
+type Operation =
+ NoOp
+ | SignIn String
+ | SignOut
+
+decodeOperation : Value -> Operation
+decodeOperation value =
+ Json.decodeValue operationDecoder value
+ |> Result.toMaybe
+ |> Maybe.withDefault NoOp
+
+toServerCommunication : Operation -> SC.Communication
+toServerCommunication operation =
+ case operation of
+ NoOp -> SC.NoCommunication
+ SignIn assertion -> SC.SignIn assertion
+ SignOut -> SC.SignOut
+
+operationDecoder : Decoder Operation
+operationDecoder =
+ ("operation" := Json.string) `Json.andThen` operationDecoderWithTag
+
+operationDecoderWithTag : String -> Decoder Operation
+operationDecoderWithTag operation =
+ case operation of
+ "SignIn" ->
+ Json.map SignIn ("assertion" := Json.string)
+ "SignOut" ->
+ Json.succeed SignOut
+ _ ->
+ Json.succeed NoOp
diff --git a/src/client/elm/SimpleHTTP.elm b/src/client/elm/SimpleHTTP.elm
new file mode 100644
index 0000000..99a7056
--- /dev/null
+++ b/src/client/elm/SimpleHTTP.elm
@@ -0,0 +1,41 @@
+module SimpleHTTP
+ ( post
+ , decodeHttpValue
+ ) where
+
+import Http exposing (..)
+import Task exposing (..)
+import Json.Decode as Json exposing (Decoder)
+
+post : String -> Task Error Value
+post url =
+ { verb = "POST"
+ , headers = []
+ , url = url
+ , body = empty
+ }
+ |> Http.send defaultSettings
+ |> mapError promoteError
+ |> flip Task.andThen handleResponse
+
+handleResponse : Response -> Task Error Value
+handleResponse response =
+ if 200 <= response.status && response.status < 300
+ then Task.succeed response.value
+ else fail (BadResponse response.status response.statusText)
+
+promoteError : RawError -> Error
+promoteError rawError =
+ case rawError of
+ RawTimeout -> Timeout
+ RawNetworkError -> NetworkError
+
+decodeHttpValue : Decoder a -> Value -> Task Error a
+decodeHttpValue decoder value =
+ case value of
+ Text str ->
+ case Json.decodeString decoder str of
+ Ok v -> succeed v
+ Err msg -> fail (UnexpectedPayload msg)
+ _ ->
+ fail (UnexpectedPayload "Response body is a blob, expecting a string.")
diff --git a/src/client/Update.elm b/src/client/elm/Update.elm
index 3c4614a..3c4614a 100644
--- a/src/client/Update.elm
+++ b/src/client/elm/Update.elm
diff --git a/src/client/Update/LoggedIn.elm b/src/client/elm/Update/LoggedIn.elm
index e477094..e477094 100644
--- a/src/client/Update/LoggedIn.elm
+++ b/src/client/elm/Update/LoggedIn.elm
diff --git a/src/client/Update/LoggedIn/Account.elm b/src/client/elm/Update/LoggedIn/Account.elm
index cf4c834..cf4c834 100644
--- a/src/client/Update/LoggedIn/Account.elm
+++ b/src/client/elm/Update/LoggedIn/Account.elm
diff --git a/src/client/Update/LoggedIn/Add.elm b/src/client/elm/Update/LoggedIn/Add.elm
index 1f28997..1f28997 100644
--- a/src/client/Update/LoggedIn/Add.elm
+++ b/src/client/elm/Update/LoggedIn/Add.elm
diff --git a/src/client/Update/LoggedIn/Monthly.elm b/src/client/elm/Update/LoggedIn/Monthly.elm
index 1379323..1379323 100644
--- a/src/client/Update/LoggedIn/Monthly.elm
+++ b/src/client/elm/Update/LoggedIn/Monthly.elm
diff --git a/src/client/Update/SignIn.elm b/src/client/elm/Update/SignIn.elm
index 0aa7c84..cabe4cb 100644
--- a/src/client/Update/SignIn.elm
+++ b/src/client/elm/Update/SignIn.elm
@@ -6,19 +6,10 @@ module Update.SignIn
import Model.View.SignInView exposing (..)
type SignInAction =
- UpdateLogin String
- | ValidLogin String
- | ErrorLogin String
+ ErrorLogin String
updateSignIn : SignInAction -> SignInView -> SignInView
updateSignIn action signInView =
case action of
- UpdateLogin login ->
- { signInView | login <- login }
- ValidLogin message ->
- { signInView
- | login <- ""
- , result <- Just (Ok message)
- }
ErrorLogin message ->
{ signInView | result <- Just (Err message) }
diff --git a/src/client/Utils/Dict.elm b/src/client/elm/Utils/Dict.elm
index dc01b17..dc01b17 100644
--- a/src/client/Utils/Dict.elm
+++ b/src/client/elm/Utils/Dict.elm
diff --git a/src/client/Utils/Either.elm b/src/client/elm/Utils/Either.elm
index 10c40e3..10c40e3 100644
--- a/src/client/Utils/Either.elm
+++ b/src/client/elm/Utils/Either.elm
diff --git a/src/client/Utils/Maybe.elm b/src/client/elm/Utils/Maybe.elm
index d954ae0..d954ae0 100644
--- a/src/client/Utils/Maybe.elm
+++ b/src/client/elm/Utils/Maybe.elm
diff --git a/src/client/Utils/Validation.elm b/src/client/elm/Utils/Validation.elm
index b9bccb3..b9bccb3 100644
--- a/src/client/Utils/Validation.elm
+++ b/src/client/elm/Utils/Validation.elm
diff --git a/src/client/View/Date.elm b/src/client/elm/View/Date.elm
index 81c5112..81c5112 100644
--- a/src/client/View/Date.elm
+++ b/src/client/elm/View/Date.elm
diff --git a/src/client/View/Events.elm b/src/client/elm/View/Events.elm
index 1eb9027..1eb9027 100644
--- a/src/client/View/Events.elm
+++ b/src/client/elm/View/Events.elm
diff --git a/src/client/View/Expand.elm b/src/client/elm/View/Expand.elm
index 53b4fe5..53b4fe5 100644
--- a/src/client/View/Expand.elm
+++ b/src/client/elm/View/Expand.elm
diff --git a/src/client/View/Header.elm b/src/client/elm/View/Header.elm
index 9d31183..3a6241b 100644
--- a/src/client/View/Header.elm
+++ b/src/client/elm/View/Header.elm
@@ -6,8 +6,7 @@ import Html exposing (..)
import Html.Attributes exposing (..)
import Html.Events exposing (..)
-import ServerCommunication as SC
-import ServerCommunication exposing (serverCommunications)
+import Persona exposing (operations)
import Model exposing (Model)
import Model.View exposing (..)
@@ -26,11 +25,15 @@ renderHeader model =
LoadingView ->
text ""
SignInView _ ->
- text ""
+ button
+ [ class "icon"
+ , onClick operations.address Persona.SignIn
+ ]
+ [ renderIcon "sign-in" ]
LoggedInView _ ->
button
- [ class "signOut"
- , onClick serverCommunications.address SC.SignOut
+ [ class "icon"
+ , onClick operations.address Persona.SignOut
]
- [ renderIcon "power-off" ]
+ [ renderIcon "sign-out" ]
]
diff --git a/src/client/View/Icon.elm b/src/client/elm/View/Icon.elm
index f22c1a2..f22c1a2 100644
--- a/src/client/View/Icon.elm
+++ b/src/client/elm/View/Icon.elm
diff --git a/src/client/View/Loading.elm b/src/client/elm/View/Loading.elm
index f8c6cd6..f8c6cd6 100644
--- a/src/client/View/Loading.elm
+++ b/src/client/elm/View/Loading.elm
diff --git a/src/client/View/LoggedIn.elm b/src/client/elm/View/LoggedIn.elm
index 96916e0..96916e0 100644
--- a/src/client/View/LoggedIn.elm
+++ b/src/client/elm/View/LoggedIn.elm
diff --git a/src/client/View/LoggedIn/Account.elm b/src/client/elm/View/LoggedIn/Account.elm
index 706f7cc..706f7cc 100644
--- a/src/client/View/LoggedIn/Account.elm
+++ b/src/client/elm/View/LoggedIn/Account.elm
diff --git a/src/client/View/LoggedIn/Add.elm b/src/client/elm/View/LoggedIn/Add.elm
index 572bdf6..572bdf6 100644
--- a/src/client/View/LoggedIn/Add.elm
+++ b/src/client/elm/View/LoggedIn/Add.elm
diff --git a/src/client/View/LoggedIn/Monthly.elm b/src/client/elm/View/LoggedIn/Monthly.elm
index a274015..a274015 100644
--- a/src/client/View/LoggedIn/Monthly.elm
+++ b/src/client/elm/View/LoggedIn/Monthly.elm
diff --git a/src/client/View/LoggedIn/Paging.elm b/src/client/elm/View/LoggedIn/Paging.elm
index 93d7f1d..93d7f1d 100644
--- a/src/client/View/LoggedIn/Paging.elm
+++ b/src/client/elm/View/LoggedIn/Paging.elm
diff --git a/src/client/View/LoggedIn/Table.elm b/src/client/elm/View/LoggedIn/Table.elm
index f5a08b5..f5a08b5 100644
--- a/src/client/View/LoggedIn/Table.elm
+++ b/src/client/elm/View/LoggedIn/Table.elm
diff --git a/src/client/View/Page.elm b/src/client/elm/View/Page.elm
index 763734d..763734d 100644
--- a/src/client/View/Page.elm
+++ b/src/client/elm/View/Page.elm
diff --git a/src/client/View/Price.elm b/src/client/elm/View/Price.elm
index 286bcaa..286bcaa 100644
--- a/src/client/View/Price.elm
+++ b/src/client/elm/View/Price.elm
diff --git a/src/client/View/SignIn.elm b/src/client/elm/View/SignIn.elm
index 2a6cbca..8fcac16 100644
--- a/src/client/View/SignIn.elm
+++ b/src/client/elm/View/SignIn.elm
@@ -24,18 +24,7 @@ renderSignIn : Model -> SignInView -> Html
renderSignIn model signInView =
div
[ class "signIn" ]
- [ H.form
- [ onSubmitPrevDefault serverCommunications.address (SC.SignIn signInView.login) ]
- [ input
- [ value signInView.login
- , on "input" targetValue (Signal.message actions.address << UpdateSignIn << UpdateLogin)
- ]
- []
- , button
- []
- [ text (getMessage "SignIn" model.translations)]
- ]
- , div
+ [ div
[ class "result" ]
[ signInResult model signInView ]
]
diff --git a/src/client/js/main.js b/src/client/js/main.js
new file mode 100644
index 0000000..12593e6
--- /dev/null
+++ b/src/client/js/main.js
@@ -0,0 +1,28 @@
+var app = Elm.fullscreen(Elm.Main, {
+ initialTime: new Date().getTime(),
+ translations: document.getElementById('messages').innerHTML,
+ config: document.getElementById('config').innerHTML,
+ sign: null
+});
+
+navigator.id.watch({
+ loggedInUser: null,
+ onlogin: function(assertion) {
+ app.ports.sign.send({
+ operation: 'SignIn',
+ assertion: assertion
+ });
+ },
+ onlogout: function() {}
+});
+
+app.ports.persona.subscribe(function(communication) {
+ if(communication === 'SignIn') {
+ navigator.id.request();
+ } else if(communication === 'SignOut') {
+ navigator.id.logout();
+ app.ports.sign.send({
+ operation: 'SignOut'
+ });
+ }
+});
diff --git a/src/server/Config.hs b/src/server/Config.hs
index bd7f325..37f57ec 100644
--- a/src/server/Config.hs
+++ b/src/server/Config.hs
@@ -18,7 +18,6 @@ import Control.Arrow (left)
data Config = Config
{ hostname :: Text
, port :: Int
- , signInExpirationMn :: Int
, currency :: Text
} deriving (Read, Eq, Show)
@@ -29,6 +28,5 @@ getConfig filePath =
Config <$>
(T.pack <$> get cp "DEFAULT" "hostname") <*>
(get cp "DEFAULT" "port") <*>
- (get cp "DEFAULT" "sign-in-expiration-mn") <*>
(T.pack <$> get cp "DEFAULT" "currency")
)
diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
index 31cd510..8eceb56 100644
--- a/src/server/Controller/SignIn.hs
+++ b/src/server/Controller/SignIn.hs
@@ -2,32 +2,21 @@
module Controller.SignIn
( signIn
- , validateSignIn
) where
import Web.Scotty
import Network.HTTP.Types.Status (ok200)
-import Database.Persist
-
import Control.Monad.IO.Class (liftIO)
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.Time.Clock (getCurrentTime, diffUTCTime)
import Data.Maybe (isJust)
import qualified LoginSession
import Config
-import SendMail
-
-import Text.Email.Validate as Email
-
import Model.Database
import Model.User
import Model.SignIn
@@ -36,65 +25,20 @@ import Model.Message (getMessage)
import Json (jsonError)
-import Secure (getUserFromToken)
-
-import qualified View.Mail.SignIn as SignIn
+import Persona (verifyEmail)
signIn :: Config -> Text -> ActionM ()
-signIn config login =
- if Email.isValid (TE.encodeUtf8 login)
- then do
- maybeUser <- liftIO . runDb $ getUser login
- case maybeUser of
- Just user -> do
- token <- liftIO . runDb $ createSignInToken login
- let url = T.concat ["http://", hostname config, "/validateSignIn?token=", token]
- maybeSentMail <- liftIO . sendMail $ SignIn.getMail (entityVal user) url [login]
- case maybeSentMail of
- Right _ ->
- status ok200
- Left _ ->
- jsonError (getMessage SendEmailFail)
- Nothing ->
- jsonError (getMessage Unauthorized)
- else
- jsonError (getMessage EnterValidEmail)
-
-validateSignIn :: Config -> Text -> ActionM ()
-validateSignIn config textToken = do
- alreadySigned <- isAlreadySigned
- if alreadySigned
- then
- redirect "/"
- else do
- mbSignIn <- liftIO . runDb $ getSignInToken textToken
- now <- liftIO getCurrentTime
- case mbSignIn of
- Just signIn ->
- if signInIsUsed . entityVal $ signIn
- then
- redirectError (getMessage SignInUsed)
- else
- let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signIn)
- in if diffTime > (fromIntegral $ (signInExpirationMn config) * 60)
- then
- redirectError (getMessage SignInExpired)
- else do
- LoginSession.put (signInToken . entityVal $ signIn)
- liftIO . runDb . signInTokenToUsed . entityKey $ signIn
- redirect "/"
- Nothing ->
- redirectError (getMessage SignInInvalid)
-
-isAlreadySigned :: ActionM Bool
-isAlreadySigned = do
- mbToken <- LoginSession.get
- case mbToken of
+signIn config assertion = do
+ mbEmail <- liftIO $ verifyEmail config assertion
+ case mbEmail of
Nothing ->
- return False
- Just token -> do
- liftIO . runDb . fmap isJust $ getUserFromToken token
-
-redirectError :: Text -> ActionM ()
-redirectError msg =
- redirect . TL.fromStrict . T.concat $ ["/?signInError=", msg]
+ jsonError (getMessage InvalidEmail)
+ Just email -> do
+ isAuthorized <- liftIO . fmap isJust . runDb $ getUser email
+ if isAuthorized
+ then do
+ token <- liftIO . runDb $ createSignInToken email
+ LoginSession.put token
+ status ok200
+ else
+ jsonError (getMessage Unauthorized)
diff --git a/src/server/Design/Header.hs b/src/server/Design/Header.hs
index 7b82577..9f83778 100644
--- a/src/server/Design/Header.hs
+++ b/src/server/Design/Header.hs
@@ -25,7 +25,7 @@ headerDesign =
marginBottom blockMarginBottom
paddingLeft sidePercent
- button # ".signOut" ? do
+ button # ".icon" ? do
let iconHeight = 50
let sideMargin = ((headerHeight - iconHeight) `Prelude.div` 2)
position absolute
diff --git a/src/server/Design/SignIn.hs b/src/server/Design/SignIn.hs
index 6bacc3a..7aff720 100644
--- a/src/server/Design/SignIn.hs
+++ b/src/server/Design/SignIn.hs
@@ -15,26 +15,6 @@ signInDesign =
".signIn" ? do
- opacityAnimation
-
- form ? do
- let inputHeight = 50
- width (px 500)
- marginTop (px 100)
- marginLeft auto
- marginRight auto
-
- input ? do
- defaultInput inputHeight
- display block
- width (pct 100)
- marginBottom (px 10)
-
- button ? do
- defaultButton C.red C.white (px inputHeight)
- display block
- width (pct 100)
-
".result" ? do
marginTop (px 40)
textAlign (alignSide sideCenter)
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 3d61481..3539120 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -8,7 +8,7 @@ import Control.Concurrent (forkIO)
import MonthlyPaymentJob (monthlyPaymentJobListener)
import Data.Text (Text)
-import qualified Data.Text.IO as TIO
+import qualified Data.Text.IO as T
import Controller.Index
import Controller.SignIn
@@ -28,7 +28,7 @@ main = do
eitherConfig <- Config.getConfig "config.txt"
case eitherConfig of
Left errorMessage ->
- TIO.putStrLn errorMessage
+ T.putStrLn errorMessage
Right config -> do
scotty (Config.port config) $ do
middleware $
@@ -40,12 +40,8 @@ main = do
-- SignIn
post "/signIn" $ do
- login <- param "login" :: ActionM Text
- signIn config login
-
- get "/validateSignIn" $ do
- token <- param "token" :: ActionM Text
- validateSignIn config token
+ assertion <- param "assertion" :: ActionM Text
+ signIn config assertion
-- Users
diff --git a/src/server/Model/Database.hs b/src/server/Model/Database.hs
index 8d1da25..67cc8b3 100644
--- a/src/server/Model/Database.hs
+++ b/src/server/Model/Database.hs
@@ -44,7 +44,6 @@ SignIn
token Text
creation UTCTime
email Text
- isUsed Bool
UniqSignInToken token
deriving Show
Job
diff --git a/src/server/Model/Message/Key.hs b/src/server/Model/Message/Key.hs
index e9f8ef6..7f49ae7 100644
--- a/src/server/Model/Message/Key.hs
+++ b/src/server/Model/Message/Key.hs
@@ -12,12 +12,8 @@ data Key =
| SharedCost
| SignIn
- | SendEmailFail
+ | InvalidEmail
| Unauthorized
- | EnterValidEmail
- | SignInUsed
- | SignInExpired
- | SignInInvalid
| SignInMailTitle
| SignInMail
| SignInEmailSent
diff --git a/src/server/Model/Message/Translations.hs b/src/server/Model/Message/Translations.hs
index a2e9a30..29b21ea 100644
--- a/src/server/Model/Message/Translations.hs
+++ b/src/server/Model/Message/Translations.hs
@@ -34,36 +34,16 @@ m l SignIn =
English -> "Sign in"
French -> "Connexion"
-m l SendEmailFail =
+m l InvalidEmail =
case l of
- English -> "Sorry, we failed to send you the sign up email."
- French -> "Désolé, nous n'avons pas pu t'envoyer le courriel de connexion."
+ English -> "Your email is not valid."
+ French -> "Votre courriel n'est pas valide."
m l Unauthorized =
case l of
English -> "You are not authorized to sign in."
French -> "Tu n'es pas autorisé à te connecter."
-m l EnterValidEmail =
- case l of
- English -> "Please enter a valid email address."
- French -> "Ton courriel n'est pas valide."
-
-m l SignInUsed =
- 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 SignInExpired =
- 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 SignInInvalid =
- 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 SignInMailTitle =
case l of
English -> T.concat ["Sign in to ", m l SharedCost]
diff --git a/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs
index 117b8b5..b475fdb 100644
--- a/src/server/Model/SignIn.hs
+++ b/src/server/Model/SignIn.hs
@@ -1,8 +1,6 @@
module Model.SignIn
( createSignInToken
, getSignInToken
- , signInTokenToUsed
- , isLastValidToken
) where
import Data.Text (Text)
@@ -19,22 +17,9 @@ createSignInToken :: Text -> Persist Text
createSignInToken email = do
now <- liftIO getCurrentTime
token <- liftIO generateUUID
- _ <- insert $ SignIn token now email False
+ _ <- insert $ SignIn token now email
return token
getSignInToken :: Text -> Persist (Maybe (Entity SignIn))
getSignInToken token =
selectFirst [SignInToken ==. token] []
-
-signInTokenToUsed :: SignInId -> Persist ()
-signInTokenToUsed tokenId =
- update tokenId [SignInIsUsed =. True]
-
-isLastValidToken :: SignIn -> Persist Bool
-isLastValidToken signIn = do
- maybe False ((== (signInToken signIn)) . signInToken . entityVal) <$>
- selectFirst
- [ SignInEmail ==. (signInEmail signIn)
- , SignInIsUsed ==. True
- ]
- [ Desc SignInCreation ]
diff --git a/src/server/Persona.hs b/src/server/Persona.hs
new file mode 100644
index 0000000..8055e8b
--- /dev/null
+++ b/src/server/Persona.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Persona
+ ( verifyEmail
+ ) where
+
+import Control.Monad (guard)
+
+import Network.HTTP.Conduit
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.ByteString.Lazy (fromStrict, toStrict)
+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
+import Data.Aeson
+import Data.Aeson.Types (parseMaybe)
+
+import Config
+
+verifyEmail :: Config -> Text -> IO (Maybe Text)
+verifyEmail config assertion = do
+
+ initReq <- parseUrl "https://verifier.login.persona.org/verify"
+
+ let request =
+ (flip urlEncodedBody) initReq $
+ [ ("assertion", encodeUtf8 $ assertion)
+ , ("audience", encodeUtf8 $ hostname config)
+ ]
+
+ manager <- newManager tlsManagerSettings
+ response <- httpLbs request manager
+
+ return . parseEmail . decodeUtf8 . toStrict . responseBody $ response
+
+parseEmail :: Text -> Maybe Text
+parseEmail payload = do
+ result <- decode . fromStrict . encodeUtf8 $ payload
+ flip parseMaybe result $ \obj -> do
+ status <- T.pack <$> obj .: "status"
+ guard (status == "okay")
+ obj .: "email"
diff --git a/src/server/Secure.hs b/src/server/Secure.hs
index 192fa10..7b6e6de 100644
--- a/src/server/Secure.hs
+++ b/src/server/Secure.hs
@@ -12,7 +12,7 @@ import Network.HTTP.Types.Status (forbidden403)
import Database.Persist (Entity, entityVal)
import Model.User (getUser)
-import Model.SignIn (getSignInToken, isLastValidToken)
+import Model.SignIn (getSignInToken)
import Model.Database
import Control.Monad.IO.Class (liftIO)
@@ -44,9 +44,6 @@ getUserFromToken token = do
mbSignIn <- fmap entityVal <$> getSignInToken token
case mbSignIn of
Just signIn -> do
- isValid <- isLastValidToken signIn
- if isValid
- then getUser (signInEmail signIn)
- else return Nothing
+ getUser (signInEmail signIn)
Nothing ->
return Nothing
diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs
index 2865337..7310fbb 100644
--- a/src/server/View/Page.hs
+++ b/src/server/View/Page.hs
@@ -26,7 +26,9 @@ page config =
renderHtml . docTypeHtml $ do
H.head $ do
meta ! charset "UTF-8"
+ meta ! httpEquiv "X-UA-Compatible" ! content "IE=Edge" -- IE8+ only is valid to use with persona
H.title (toHtml $ getMessage SharedCost)
+ script ! src "https://login.persona.org/include.js" $ ""
script ! src "javascripts/client.js" $ ""
script ! A.id "messages" ! type_ "application/json" $ toHtml . decodeUtf8 . encode $ getTranslations
script ! A.id "config" ! type_ "application/json" $ toHtml . decodeUtf8 . encode $ config
@@ -35,4 +37,4 @@ page config =
link ! rel "icon" ! type_ "image/png" ! href "images/icon.png"
H.style $ toHtml globalDesign
body $ do
- script ! src "javascripts/elmLauncher.js" $ ""
+ script ! src "javascripts/main.js" $ ""