Browse Source

init

main
Gil Mizrahi 11 months ago
commit
09a05e75a1
14 changed files with 817 additions and 0 deletions
  1. +51
    -0
      .gitignore
  2. +30
    -0
      LICENSE
  3. +46
    -0
      app/Main.hs
  4. +65
    -0
      my-scotty-users.cabal
  5. +12
    -0
      readme.md
  6. +40
    -0
      src/Web/Scotty/Sqlite/Users.hs
  7. +13
    -0
      src/Web/Scotty/Sqlite/Users/Common.hs
  8. +56
    -0
      src/Web/Scotty/Sqlite/Users/DbAccess.hs
  9. +122
    -0
      src/Web/Scotty/Sqlite/Users/Login.hs
  10. +32
    -0
      src/Web/Scotty/Sqlite/Users/Model.hs
  11. +194
    -0
      src/Web/Scotty/Sqlite/Users/NewUser.hs
  12. +138
    -0
      src/Web/Scotty/Sqlite/Users/Session.hs
  13. +5
    -0
      stack.yaml
  14. +13
    -0
      stack.yaml.lock

+ 51
- 0
.gitignore View File

@@ -0,0 +1,51 @@
client_session_key.aes

# Created by https://www.gitignore.io/api/haskell,emacs

### Haskell ###
dist
dist-*
cabal-dev
*.o
*.hi
*.chi
*.chs.h
*.dyn_o
*.dyn_hi
.hpc
.hsenv
.cabal-sandbox/
cabal.sandbox.config
*.prof
*.aux
*.hp
*.eventlog
.stack-work/
cabal.project.local
.HTF/


### Emacs ###
# -*- mode: gitignore; -*-
*~
\#*\#
/.emacs.desktop
/.emacs.desktop.lock
*.elc
auto-save-list
tramp
.\#*

# Org-mode
.org-id-locations
*_archive

# flymake-mode
*_flymake.*

# eshell files
/eshell/history
/eshell/lastdir

# elpa packages
/elpa/

+ 30
- 0
LICENSE View File

@@ -0,0 +1,30 @@
Copyright (c) 2020, Gil Mizrahi

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.

* Neither the name of Gil Mizrahi nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ 46
- 0
app/Main.hs View File

@@ -0,0 +1,46 @@
{-# language OverloadedStrings #-}

module Main where

import qualified Control.Monad.Logger as Log
import qualified Web.Scotty as S
import qualified Data.Text.Lazy as TL
import qualified Database.Persist.Sqlite as PSqlite3
import Control.Monad.IO.Class (liftIO)
import qualified Lucid as H

import qualified Web.Scotty.Sqlite.Users as Users

main :: IO ()
main = do
pool <- do
Log.runStderrLoggingT $ PSqlite3.createSqlitePool "file:/tmp/my-scotty-users.db" 1
liftIO $ Users.dbMigrations pool
ses <- Users.initSessionStore
S.scotty 8080 (myApp pool ses)

myApp :: Users.Pool -> Users.SessionStore -> S.ScottyM ()
myApp pool ses = do
S.get "/" $ index pool ses
Users.router pool ses template

index :: Users.Pool -> Users.SessionStore -> S.ActionM ()
index pool sessionStore = do
io <- Users.loginOrLogout pool sessionStore
S.html $
H.renderText $
template
("Bulletin board")
io

type Html = H.Html ()

template :: TL.Text -> Html -> Html
template title content =
H.doctypehtml_ $ do
H.head_ $ do
H.meta_ [ H.charset_ "utf-8" ]
H.title_ (H.toHtml title)
H.link_ [ H.rel_ "stylesheet", H.type_ "text/css", H.href_ "/style.css" ]
H.body_ $ do
content

+ 65
- 0
my-scotty-users.cabal View File

@@ -0,0 +1,65 @@
name: my-scotty-users
version: 0.1.0.0
synopsis: User authentication for scotty
description: Please see readme.md
homepage: https://gitlab.com/gilmi/my-scotty-users
license-file: LICENSE
author: Gil Mizrahi
maintainer: gilmi@posteo.net
copyright: 2020 Gil Mizrahi
category: Web
build-type: Simple
cabal-version: >=1.10
extra-source-files: readme.md

library
hs-source-dirs: src
exposed-modules:
Web.Scotty.Sqlite.Users
Web.Scotty.Sqlite.Users.Common
Web.Scotty.Sqlite.Users.DbAccess
Web.Scotty.Sqlite.Users.Login
Web.Scotty.Sqlite.Users.Model
Web.Scotty.Sqlite.Users.NewUser
Web.Scotty.Sqlite.Users.Session


ghc-options: -Wall -fno-warn-type-defaults
default-language: Haskell2010
build-depends: base >= 4.7 && < 5
, text
, time
, bytestring
, containers
-- web
, lucid
, scotty
, wai
, wai-extra
, http-types
, persistent
, persistent-template
, persistent-sqlite
-- auth
, stm
, binary
, cookie
, password
, clientsession

executable my-scotty-users-example
hs-source-dirs: app
main-is: Main.hs
default-language: Haskell2010
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
build-depends: base >= 4.7 && < 5
, my-scotty-users

, text
, time
, monad-logger
-- web
, lucid
, scotty
, wai
, persistent-sqlite

+ 12
- 0
readme.md View File

@@ -0,0 +1,12 @@
# My scotty users boilerplate

User registration, authentication, sessions and boilerplate.

check the [example](/app/Main.hs).

## Build with

```sh
stack build
```


+ 40
- 0
src/Web/Scotty/Sqlite/Users.hs View File

@@ -0,0 +1,40 @@
{-# language OverloadedStrings #-}
{-# language MultiWayIf #-}

module Web.Scotty.Sqlite.Users
( router
, initSessionStore
, dbMigrations
, Login.loginOrLogout
, Pool
, HtmlTemplate
, SessionStore
, withLogin
, getSession
, module Web.Scotty.Sqlite.Users.Model
)
where

import qualified Web.Scotty as S

import Web.Scotty.Sqlite.Users.Model
import Web.Scotty.Sqlite.Users.DbAccess
import Web.Scotty.Sqlite.Users.Common
import Web.Scotty.Sqlite.Users.Session

import qualified Web.Scotty.Sqlite.Users.Login as Login
import qualified Web.Scotty.Sqlite.Users.NewUser as NewUser

-------------
-- Routing --
-------------

router :: Pool -> SessionStore -> HtmlTemplate -> S.ScottyM ()
router pool sessionStore template = do
Login.router pool sessionStore template
NewUser.router pool sessionStore template


withLogin :: SessionStore -> (LoginId -> S.ActionM ()) -> S.ActionM ()
withLogin sessionStore exec =
maybe (S.redirect "/login") exec =<< getSession sessionStore

+ 13
- 0
src/Web/Scotty/Sqlite/Users/Common.hs View File

@@ -0,0 +1,13 @@
module Web.Scotty.Sqlite.Users.Common where

import qualified Data.Text.Lazy as TL
import qualified Lucid as H

type Html = H.Html ()
type HtmlTemplate = TL.Text -> Html -> Html

applyMaybe :: Applicative m => Maybe a -> (a -> m ()) -> m ()
applyMaybe m f =
case m of
Nothing -> pure ()
Just x -> f x

+ 56
- 0
src/Web/Scotty/Sqlite/Users/DbAccess.hs View File

@@ -0,0 +1,56 @@
{-# LANGUAGE OverloadedStrings #-}

module Web.Scotty.Sqlite.Users.DbAccess where

import qualified Data.Text.Lazy as TL
import qualified Database.Persist as P
import qualified Database.Persist.Sql as P
import qualified Database.Persist.Sqlite as PSqlite3
import qualified Data.Password.Bcrypt as Bcrypt
import Data.Password.Bcrypt (PasswordHash(..), Password, Bcrypt, PasswordCheck(..))

import Web.Scotty.Sqlite.Users.Model


type Pool = PSqlite3.ConnectionPool

-- General --

runDB :: Pool -> P.SqlPersistT IO a -> IO a
runDB pool dbop = P.runSqlPool dbop pool

dbMigrations :: Pool -> IO ()
dbMigrations pool = runDB pool $ PSqlite3.runMigration migrateAll

-- Login --

insertUser :: Pool -> Username -> PasswordHash Bcrypt -> Displayname -> IO (P.Key Login)
insertUser pool username passhash displayname = do
runDB pool $ P.insert (Login username (Bcrypt.unPasswordHash passhash) displayname)

checkUser :: Pool -> Username -> Password -> IO (Maybe (P.Key Login))
checkUser pool user pass = do
list <- runDB pool $ do
P.selectList [ LoginUsername P.==. user ] []
pure $ case list of
[P.Entity uid u] ->
case Bcrypt.checkPassword pass (PasswordHash $ loginPasswordHash u) of
PasswordCheckSuccess ->
Just uid
PasswordCheckFail ->
Nothing
_ -> Nothing

-- Users --

getAllUsers :: Pool -> IO Logins
getAllUsers pool = do
runDB pool $ P.selectList [] []

getLogin :: Pool -> LoginId -> IO (Maybe Login)
getLogin pool = runDB pool . P.get

getLoginByUsername :: Pool -> TL.Text -> IO (Maybe (P.Entity Login))
getLoginByUsername pool username = do
runDB pool $ P.getBy (Username username)


+ 122
- 0
src/Web/Scotty/Sqlite/Users/Login.hs View File

@@ -0,0 +1,122 @@
{-# language OverloadedStrings #-}

module Web.Scotty.Sqlite.Users.Login where


import Control.Monad.IO.Class (liftIO)
import Control.Monad (join)
import qualified Data.Password.Bcrypt as Bcrypt
import qualified Data.Text.Lazy as TL
import qualified Lucid as H
import qualified Web.Scotty as S

import qualified Web.Scotty.Sqlite.Users.DbAccess as DB
import Web.Scotty.Sqlite.Users.Session
import Web.Scotty.Sqlite.Users.Model
import Web.Scotty.Sqlite.Users.Common

-----------------
-- Login Route --
-----------------

router :: DB.Pool -> SessionStore -> HtmlTemplate -> S.ScottyM ()
router pool sessionStore template = do
-- A Log in page
S.get "/login" $ do
mses <- getSession sessionStore
case mses of
Nothing ->
serveLoginForm template Nothing
_ ->
S.redirect "/"

-- A request to log in
S.post "/login" $ do
mses <- getSession sessionStore
case mses of
Nothing -> do
username <- S.param "username"
password <- S.param "password"
submitLoginForm pool sessionStore template username password
_ ->
S.redirect "/"

-- Logout
S.post "/logout" $ do
mapM_ (deleteSession sessionStore) =<< getSession sessionStore
S.redirect "/"


-------------------
-- Login Actions --
-------------------

loginOrLogout :: DB.Pool -> SessionStore -> S.ActionM Html
loginOrLogout pool sessionStore = do
muser <- liftIO . fmap join . traverse (DB.getLogin pool) =<< getSession sessionStore
pure $
H.div_ [ H.class_ "welcome" ] $
case muser of
Just user ->
mconcat
[ "Welcome " <> H.toHtml (loginDisplayName user)
, " "
, H.form_ [H.method_ "post" , H.action_ "/logout", H.class_ "logout-form"] $
H.input_ [H.type_ "submit", H.value_ "Log out", H.class_ "logout"]
]
Nothing ->
mconcat
[ " " <> H.a_ [ H.href_ "/login" ] "Log in"
, " | " <> H.a_ [ H.href_ "/register" ] "Register"
]


serveLoginForm :: HtmlTemplate -> Maybe TL.Text -> S.ActionM ()
serveLoginForm template err = do
S.html $
H.renderText $
template
("Scotty.Sqlite board - register a new account")
(loginHtml err)

submitLoginForm :: DB.Pool -> SessionStore -> HtmlTemplate -> TL.Text -> TL.Text -> S.ActionM ()
submitLoginForm pool ses template username pass = do
mUserId <- liftIO $ DB.checkUser pool username $ Bcrypt.mkPassword (TL.toStrict pass)
case mUserId of
Nothing ->
serveLoginForm template $ Just "Bad username or password."
Just uid -> do
newSession ses uid
S.redirect "/"

----------------
-- Login Html --
----------------

loginHtml :: Maybe TL.Text -> Html
loginHtml err = do
H.form_
[ H.method_ "post"
, H.action_ "/login"
, H.class_ "login"
]
( do
applyMaybe err (H.p_ [ H.class_ "error" ] . H.toHtml)
H.p_ $
H.input_
[ H.type_ "text"
, H.required_ "true"
, H.name_ "username"
, H.placeholder_ "Username..."
, H.autofocus_
]
H.p_ $
H.input_
[ H.type_ "password"
, H.required_ "true"
, H.name_ "password"
, H.placeholder_ "Password..."
]

H.p_ $ H.input_ [H.type_ "submit", H.value_ "Log In", H.class_ "submit-button"]
)

+ 32
- 0
src/Web/Scotty/Sqlite/Users/Model.hs View File

@@ -0,0 +1,32 @@
{-# language TemplateHaskell #-}
{-# language QuasiQuotes #-}
{-# language TypeFamilies #-}
{-# language GADTs #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}

module Web.Scotty.Sqlite.Users.Model where

import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Database.Persist as P
import qualified Database.Persist.Sql as P
import Database.Persist.TH

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Login
username TL.Text
passwordHash T.Text
displayName TL.Text
Username username
deriving Show

|]

type Logins = [P.Entity Login]
type Username = TL.Text
type Displayname = TL.Text

+ 194
- 0
src/Web/Scotty/Sqlite/Users/NewUser.hs View File

@@ -0,0 +1,194 @@
{-# language OverloadedStrings #-}
{-# language MultiWayIf #-}

module Web.Scotty.Sqlite.Users.NewUser where

import Data.Maybe (isJust)
import Data.Char (isDigit, isLetter)
import qualified Data.Text.Lazy as TL

import Control.Monad.IO.Class (liftIO)
import qualified Data.Password.Bcrypt as Bcrypt
import qualified Lucid as H
import qualified Web.Scotty as S

import qualified Web.Scotty.Sqlite.Users.DbAccess as DB
import Web.Scotty.Sqlite.Users.Session
import Web.Scotty.Sqlite.Users.Common


-------------
-- Routing --
-------------

router :: DB.Pool -> SessionStore -> HtmlTemplate -> S.ScottyM ()
router pool sessionStore template = do
-- S.get "/users" $ do
-- users <- liftIO $ DB.getAllUsers pool
-- S.html $
-- H.renderText $
-- template
-- ("Scotty.Sqlite board - register a new account")
-- (mapM_ (H.p_ . H.toHtml . show) users)

-- A page for creating a new post
S.get "/register" $ do
mses <- getSession sessionStore
case mses of
Nothing ->
serveNewUserForm template noNewUserErrors "" "" ""
_ ->
S.redirect "/"

-- A request to create a new user
S.post "/register" $ do
mses <- getSession sessionStore
case mses of
Nothing -> do
username <- S.param "username"
password <- S.param "password"
confirm <- S.param "confirm"
submitNewUserForm pool sessionStore template username password confirm
_ ->
S.redirect "/"

-------------
-- Actions --
-------------

serveNewUserForm :: HtmlTemplate -> NewUserErrors -> TL.Text -> TL.Text -> TL.Text -> S.ActionM ()
serveNewUserForm template err username pass confirm = do
S.html $
H.renderText $
template
("Scotty.Sqlite board - register a new account")
(newUserHtml err username pass confirm)

submitNewUserForm :: DB.Pool -> SessionStore -> HtmlTemplate -> TL.Text -> TL.Text -> TL.Text -> S.ActionM ()
submitNewUserForm pool ses template username pass confirm = do
errs <- liftIO $ validateNewUser pool username pass confirm
if hasNewUserErrors errs
then
serveNewUserForm template errs username pass confirm
else do
hash <- liftIO $ Bcrypt.hashPassword $ Bcrypt.mkPassword (TL.toStrict pass)
ukey <- liftIO $ DB.insertUser pool username hash username
newSession ses ukey
S.redirect "/"

----------
-- Html --
----------

newUserHtml :: NewUserErrors -> TL.Text -> TL.Text -> TL.Text -> Html
newUserHtml errs username password confirm = do
H.form_
[ H.method_ "post"
, H.action_ "/register"
, H.class_ "new-user"
]
( do
applyMaybe (nueUsername errs) (H.p_ [ H.class_ "error" ] . H.toHtml)
H.p_ $
H.input_ $
[ H.type_ "text"
, H.required_ "true"
, H.name_ "username"
, H.placeholder_ "Username..."
, H.value_ (TL.toStrict username)
] <> newUserFocus Username errs
applyMaybe (nuePassword errs) (H.p_ [ H.class_ "error" ] . H.toHtml)
H.p_ $
H.input_ $
[ H.type_ "password"
, H.required_ "true"
, H.name_ "password"
, H.placeholder_ "Password..."
, H.value_ (TL.toStrict password)
] <> newUserFocus Password errs
applyMaybe (nueConfirm errs) (H.p_ [ H.class_ "error" ] . H.toHtml)
H.p_ $
H.input_ $
[ H.type_ "password"
, H.required_ "true"
, H.name_ "confirm"
, H.placeholder_ "Confirm password..."
, H.value_ (TL.toStrict confirm)
] <> newUserFocus Confirm errs
H.p_ $
H.input_
[ H.type_ "submit"
, H.value_ "Submit"
, H.class_ "submit-button"
]
)

newUserFocus :: ErrorPart -> NewUserErrors -> [H.Attribute]
newUserFocus part errs =
case part of
Username
| not (hasNewUserErrors errs) || isJust (nueUsername errs) ->
[H.autofocus_]
Password
| not (isJust (nueUsername errs)) && isJust (nuePassword errs) ->
[H.autofocus_]
Confirm
| not (isJust (nueUsername errs))
&& not (isJust (nuePassword errs))
&& isJust (nueConfirm errs) ->
[H.autofocus_]
_ -> []


----------------
-- Validation --
----------------

data ErrorPart
= Username
| Password
| Confirm

data NewUserErrors
= NewUserErrors
{ nueUsername :: Maybe TL.Text
, nuePassword :: Maybe TL.Text
, nueConfirm :: Maybe TL.Text
}
deriving (Show, Eq)


noNewUserErrors :: NewUserErrors
noNewUserErrors = NewUserErrors Nothing Nothing Nothing

hasNewUserErrors :: NewUserErrors -> Bool
hasNewUserErrors errs =
errs /= noNewUserErrors

validateNewUser :: DB.Pool -> TL.Text -> TL.Text -> TL.Text -> IO NewUserErrors
validateNewUser pool username password confirm = do
login <- DB.getLoginByUsername pool username
pure $ NewUserErrors
{ nueUsername =
if
| isJust login ->
Just "Username is already taken"
| TL.length username < 2 || TL.length username > 20 ->
Just "Username must be at least 2 characters long and at most 20 characters long"
| not $ all (\c -> isDigit c || isLetter c || c `elem` ['-','_']) (TL.unpack username) ->
Just "Usernames can only contain letters, digits, underscores or dashes"
| otherwise ->
Nothing
, nuePassword =
if TL.length password >= 8 && TL.length password <= 18
then
Nothing
else
Just "Passwords must be at least 8 character long and at most 18 characters long"
, nueConfirm =
if password /= confirm
then
Just "Password and confirmation does not match."
else
Nothing
}

+ 138
- 0
src/Web/Scotty/Sqlite/Users/Session.hs View File

@@ -0,0 +1,138 @@
{-# language OverloadedStrings #-}

module Web.Scotty.Sqlite.Users.Session
( SessionStore
, initSessionStore
, newSession
, getSession
, deleteSession
)
where

import Control.Monad (join)
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Time.Clock as Time

import Control.Monad.IO.Class (liftIO)
import qualified Control.Concurrent.STM as STM
import qualified Web.Scotty as S
import qualified Web.ClientSession as CS
import qualified Web.Cookie as C
import qualified Data.Binary.Builder as Binary

import Web.Scotty.Sqlite.Users.Model


--------------
-- Sessions --
--------------

newSession :: SessionStore -> LoginId -> S.ActionM ()
newSession sessionStore uid = do
let
suid = T.encodeUtf8 $ T.pack $ show uid
cookie <- liftIO $ BSL.fromStrict <$> encryptCookieIO (sessionKey sessionStore) (mkCookie "logged_in" suid)
S.setHeader "Set-Cookie" (TL.decodeUtf8 cookie)
liftIO $ insertLoginId uid sessionStore

getSession :: SessionStore -> S.ActionM (Maybe LoginId)
getSession sessionStore = do
bytes <- fmap TL.encodeUtf8 <$> S.header "Cookie"
cookie <- fmap join . liftIO $ traverse (decryptCookieIO (sessionKey sessionStore)) bytes
case cookie of
Just ("logged_in", suid) -> do
sessions <- liftIO $ getSessionStore sessionStore
let
uid = read (T.unpack $ T.decodeUtf8 suid)
if uid `Set.member` sessions
then pure $ Just uid
else pure $ Nothing
_ ->
pure Nothing

deleteSession :: SessionStore -> LoginId -> S.ActionM ()
deleteSession sessionStoreVar uid =
liftIO $ deleteLoginId uid sessionStoreVar

-------------------
-- Session Store --
-------------------

initSessionStore :: IO SessionStore
initSessionStore = do
SessionStore
<$> STM.newTVarIO mempty
<*> CS.getDefaultKey

data SessionStore
= SessionStore
{ sessionTVar :: STM.TVar (Set.Set LoginId)
, sessionKey :: CS.Key
}

insertLoginId :: LoginId -> SessionStore -> IO ()
insertLoginId uid sessionStore = do
STM.atomically $ STM.modifyTVar' (sessionTVar sessionStore) (Set.insert uid)

deleteLoginId :: LoginId -> SessionStore -> IO ()
deleteLoginId uid sessionStore = do
STM.atomically $ STM.modifyTVar' (sessionTVar sessionStore) (Set.delete uid)

getSessionStore :: SessionStore -> IO (Set.Set LoginId)
getSessionStore = STM.readTVarIO . sessionTVar


----------------------------
-- Cookie Encrypt/Decrypt --
----------------------------

encryptCookieIO :: CS.Key -> C.SetCookie -> IO BS.ByteString
encryptCookieIO key cookie = do
v <- CS.encryptIO key $ C.setCookieValue cookie
pure . BSL.toStrict . Binary.toLazyByteString . C.renderSetCookie $ cookie
{ C.setCookieValue = v
}

decryptCookieIO :: CS.Key -> BSL.ByteString -> IO (Maybe (BS.ByteString, BS.ByteString))
decryptCookieIO key bs =
let
(name, value) = getCookieKV (BSL.toStrict bs)
in
case CS.decrypt key value of
Nothing ->
pure Nothing
Just value' ->
pure $ Just (name, value')

-------------
-- Cookies --
-------------

mkCookie :: BS.ByteString -> BS.ByteString -> C.SetCookie
mkCookie name value =
C.defaultSetCookie
{ C.setCookieName = name
, C.setCookieValue = value
, C.setCookieSecure = True
, C.setCookieHttpOnly = True
, C.setCookieSameSite = Just C.sameSiteStrict
, C.setCookieMaxAge = Just sixtyDays
}

-- utils --

sixtyDays :: Time.DiffTime
sixtyDays = Time.secondsToDiffTime (60 * 60 * 24 * 60)

getCookieKV :: BS.ByteString -> (BS.ByteString, BS.ByteString)
getCookieKV bytes =
let
cookie = C.parseSetCookie bytes
in
(C.setCookieName cookie, C.setCookieValue cookie)


+ 5
- 0
stack.yaml View File

@@ -0,0 +1,5 @@
resolver:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/26.yaml

packages:
- .

+ 13
- 0
stack.yaml.lock View File

@@ -0,0 +1,13 @@
# This file was autogenerated by Stack.
# You should not edit this file by hand.
# For more information, please see the documentation at:
# https://docs.haskellstack.org/en/stable/lock_files

packages: []
snapshots:
- completed:
size: 533252
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/26.yaml
sha256: cdbc5db9c1afe80a5998247939027a0c7db92fa0f20b5cd01596ec3da628b622
original:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/26.yaml

Loading…
Cancel
Save