forgotten files

src/Aggreact/Users.hs

@@ -0,0 +1,25 @@
+{- |
+Module      : Aggreact.Users
+Description : Example of a library file.
+Copyright   : (c) 2018, Yann Esposito
+License     : ISC
+Maintainer  : yann.esposito@gmail.com
+Stability   : experimental
+Portability : POSIX
+
+This module is here just to re-export sub modules.
+Because the original module was split because it was too big.
+
+-}
+module Aggreact.Users
+  ( module Aggreact.Users.StoreService
+  , module Aggreact.Users.Types
+  , module Aggreact.Users.Views
+  , module Aggreact.Users.Server
+  )
+where
+
+import Aggreact.Users.StoreService
+import Aggreact.Users.Types
+import Aggreact.Users.Views
+import Aggreact.Users.Server

src/Aggreact/Users/Server.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DuplicateRecordFields      #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+
+{-# LANGUAGE BlockArguments             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE ExplicitForAll             #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedWildCards             #-}
+{-# LANGUAGE NoImplicitPrelude          #-}
+{-# LANGUAGE NumericUnderscores         #-}
+{-# LANGUAGE OverloadedLists            #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE PartialTypeSignatures      #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+
+{- |
+Module      : Aggreact.Users.Server
+Description : Server for Users
+Copyright   : (c) 2018, Yann Esposito
+License     : ISC
+Maintainer  : yann.esposito@gmail.com
+Stability   : experimental
+Portability : POSIX
+
+Provide a Store abstraction.
+
+-}
+
+module Aggreact.Users.Server
+
+where
+
+import           Protolude
+
+import           Aggreact.Users.StoreService
+import           Aggreact.Users.Types
+import           Aggreact.Users.Views
+
+import           Database.SQLite.Simple           (NamedParam (..))
+import           Database.Store
+import           Database.Store.Backend.SQLite    (SearchQuery (Filter))
+import qualified Database.Store.Backend.SQLite    as SQL
+import           Servant
+import           Servant.Auth.Server              (AuthResult (..))
+import           Servant.Errors                   as Err
+import           Servant.HTML.Blaze               (HTML)
+
+-- * User API
+
+type UserAPI =
+  "users" :> Capture "usernick" Nick :> Get '[HTML,JSON] UserPage
+  :<|> "users" :> Capture "userid" Id :> Delete '[HTML,JSON] UserDeletedPage
+  :<|> "users" :> Get '[HTML,JSON] UsersPage
+  :<|> "users" :> ReqBody '[JSON,FormUrlEncoded] NewUser
+               :> PostCreated '[HTML,JSON] RegisteredUserPage
+
+userAPI :: UserHandler
+        -- -> AuthorizationHandler
+        -> AuthResult User
+        -> Server UserAPI
+userAPI userHandler authResult =
+  let muser = case authResult of
+        (Servant.Auth.Server.Authenticated user) -> Just user
+        _                                        -> Nothing
+  in
+       getUserByNick muser userHandler
+  :<|> deleteUserById muser userHandler
+  :<|> listUsers muser userHandler
+  :<|> postUser muser userHandler
+
+-- GET User
+getUserByNick :: Maybe User -> UserHandler -> Nick -> Handler UserPage
+getUserByNick muser userHandler userNick = do
+  SQL.SR (SQL.Paginated mu _ _) <- liftIO $
+    searchUsers userHandler Filter {params = ["nick" := userNick]}
+  case mu of
+    []  -> Err.notFound "user not found"
+    [u] -> pure (UserPage u muser)
+    _   -> Err.internalServerError "Incoherent DB"
+
+getUserById :: Maybe User -> UserHandler -> Id -> Handler UserPage
+getUserById muser userHandler userId = do
+  mu <- liftIO $ readUser userHandler userId
+  case mu of
+    Nothing -> Err.notFound "user not found"
+    Just u  -> pure (UserPage u muser)

src/Aggreact/Users/StoreService.hs

@@ -0,0 +1,136 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DuplicateRecordFields      #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+
+{-# LANGUAGE BlockArguments             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE ExplicitForAll             #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedWildCards             #-}
+{-# LANGUAGE NoImplicitPrelude          #-}
+{-# LANGUAGE NumericUnderscores         #-}
+{-# LANGUAGE OverloadedLists            #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE PartialTypeSignatures      #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+
+{- |
+Module      : Aggreact.Users.StoreService
+Description : Users store specific functions
+Copyright   : (c) 2018, Yann Esposito
+License     : ISC
+Maintainer  : yann.esposito@gmail.com
+Stability   : experimental
+Portability : POSIX
+
+Provide a Store abstraction.
+
+-}
+
+module Aggreact.Users.StoreService
+
+where
+
+import           Protolude                        hiding (pass)
+
+import           Aggreact.Users.Types
+
+import qualified Crypto.Scrypt                    as Crypt
+import           Database.SQLite.Simple           (NamedParam (..))
+import           Database.Store
+import           Database.Store.Backend.SQLite    (SQLiteStore,
+                                                   SearchQuery (Filter),
+                                                   SearchResult (SR))
+import qualified Database.Store.Backend.SQLite    as SQL
+import qualified Database.Store.CRUD              as CRUD
+import qualified Database.Store.Search            as Search
+
+-- * Usage for DB
+
+type UserSQLiteStore = SQLiteStore IO DefaultMetas NewUser
+type DBStore  = StartedStore UserSQLiteStore
+type UserDBConf = DBConf UserSQLiteStore
+type UserSearchQuery  = Search.SearchQuery UserSQLiteStore
+type UserSearchResult = Search.SearchResult UserSQLiteStore
+
+hashPass :: Text -> IO HashedPassword
+hashPass pass =
+      HashedPassword . toS . Crypt.getEncryptedPass
+      <$> Crypt.encryptPassIO Crypt.defaultParams (Crypt.Pass (toS pass))
+
+initDBUsers :: UserDBConf -> NewUser -> IO DBStore
+initDBUsers conf adminUser = do
+  dbstore <- init conf
+  (SR (SQL.Paginated admins _ _)) <- searchUsers' dbstore (Filter ["role" := Admin])
+  case admins of
+    [] -> void $ createUser' dbstore adminUser
+    _  -> pure ()
+  pure dbstore
+
+stopDBUsers' :: DBStore -> IO ()
+stopDBUsers' = stop
+
+createUser' :: DBStore -> NewUser -> IO User
+createUser' dbstore nu = do
+  encpass <- hashPass (toS (password nu))
+  CRUD.create dbstore (nu { password = encpass })
+
+readUser' :: DBStore -> Id -> IO (Maybe User)
+readUser' = CRUD.read
+
+updateUser' :: DBStore -> Id -> NewUser -> IO (Maybe User)
+updateUser' = CRUD.update
+
+deleteUser' :: DBStore -> Id -> IO Bool
+deleteUser' = CRUD.delete
+
+searchUsers' :: DBStore -> UserSearchQuery -> IO UserSearchResult
+searchUsers' = Search.search
+
+data UserHandler = UserHandler
+  { createUser  :: NewUser -> IO User
+  , readUser    :: Id -> IO (Maybe User)
+  , updateUser  :: Id -> NewUser -> IO (Maybe User)
+  , deleteUser  :: Id -> IO Bool
+  , searchUsers :: UserSearchQuery -> IO UserSearchResult
+  , stopDBUsers :: IO ()
+  , dbstore     :: DBStore
+  }
+
+-- | Init a new comment handler
+newUserHandler :: UserDBConf -> NewUser -> IO UserHandler
+newUserHandler conf adminUser = do
+  dbstore <- initDBUsers conf adminUser
+  pure UserHandler { createUser  = createUser' dbstore
+                   , readUser    = readUser' dbstore
+                   , updateUser  = updateUser' dbstore
+                   , deleteUser  = deleteUser' dbstore
+                   , searchUsers = searchUsers' dbstore
+                   , stopDBUsers = stopDBUsers' dbstore
+                   , dbstore     = dbstore
+                   }
+
+-- * Security
+checkUserLogin :: UserHandler -> Text -> Text -> IO (Maybe User)
+checkUserLogin uh loginNick loginPass = do
+  (SQL.SR (SQL.Paginated users _ _)) <- searchUsers uh
+    Filter { params = [ "nick" := loginNick ]}
+  case users of
+    [user] -> do
+      let (goodPassword,_) = Crypt.verifyPass
+                               Crypt.defaultParams
+                               (Crypt.Pass (toS loginPass))
+                               (Crypt.EncryptedPass (toS (password (val user))))
+      if goodPassword
+        then pure (Just user)
+        else pure Nothing
+    _      -> pure Nothing

src/Aggreact/Users/Types.hs

@@ -0,0 +1,181 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DuplicateRecordFields      #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+
+{-# LANGUAGE BlockArguments             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE ExplicitForAll             #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedWildCards             #-}
+{-# LANGUAGE NoImplicitPrelude          #-}
+{-# LANGUAGE NumericUnderscores         #-}
+{-# LANGUAGE OverloadedLists            #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE PartialTypeSignatures      #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+
+{- |
+Module      : Aggreact.Users.Types
+Description : User related types
+Copyright   : (c) 2018, Yann Esposito
+License     : ISC
+Maintainer  : yann.esposito@gmail.com
+Stability   : experimental
+Portability : POSIX
+
+Provide a Store abstraction.
+
+-}
+
+module Aggreact.Users.Types
+
+where
+
+import           Protolude
+
+import           Data.Aeson                       (FromJSON (..), ToJSON (..))
+import           Data.Data                        (Data (..))
+import qualified Data.Text                        as Text
+import           Database.SQLite.Simple           (SQLData (..))
+
+import           Database.SQLite.Simple.FromField (FromField (..),
+                                                   ResultError (..), fieldData,
+                                                   returnError)
+import           Database.SQLite.Simple.FromRow   (FromRow (..))
+import           Database.SQLite.Simple.ToField   (ToField (..))
+import           Database.SQLite.Simple.ToRow     (ToRow (..))
+import           Database.Store
+import           Database.Store.Backend.SQLite    (SQLiteSchemas,
+                                                   ToSQLiteFieldTypeList (..))
+
+
+
+import qualified Database.Store.Backend.SQLite    as SQL
+import qualified Generics.SOP                     as SOP
+import           Servant
+import           Servant.Auth.Server              (FromJWT (..), ToJWT (..))
+
+import qualified Web.FormUrlEncoded               as Form
+import qualified Web.HttpApiData                  as FormI
+
+-- NewUser
+data NewUser =
+  NewUser { nick     :: Nick
+          , email    :: Email
+          , password :: HashedPassword
+          , role     :: Role
+          , trust    :: Int
+          } deriving (Eq,Ord,Data,Typeable,Generic,Show)
+instance Form.FromForm NewUser where
+  fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity}
+
+newtype Nick = Nick Text
+  deriving (Eq,Ord,Data,Typeable,Generic,Show)
+deriving anyclass instance FromJSON   Nick
+deriving anyclass instance ToJSON     Nick
+instance FormI.FromHttpApiData Nick where parseUrlPiece = fmap Nick . FormI.parseUrlPiece
+deriving newtype instance FromField  Nick
+deriving newtype instance ToField    Nick
+instance StringConv Nick [Char] where strConv l (Nick sl) = strConv l sl
+instance StringConv Nick Text   where strConv l (Nick sl) = strConv l sl
+instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Nick ': rest) where
+  toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
+
+data Role = User | Admin
+  deriving (Eq,Ord,Data,Typeable,Generic,Show)
+deriving anyclass instance FromJSON   Role
+deriving anyclass instance ToJSON     Role
+instance FormI.FromHttpApiData Role where
+  parseUrlPiece x =
+    case fmap Text.toLower (FormI.parseUrlPiece x) of
+      Right "user"  -> return User
+      Right "admin" -> return Admin
+      Right _       -> Left "Should be either user or admin"
+      Left err      -> Left err
+instance FromField Role where
+  fromField f = case fieldData f of
+    SQLText "User" -> return User
+    SQLText "Admin" -> return Admin
+    _ -> returnError ConversionFailed f "need a text containing User or Admin"
+instance ToField Role where
+  toField Admin = SQLText "Admin"
+  toField User  = SQLText "User"
+instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Role ': rest) where
+  toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
+
+newtype Email = Email Text
+  deriving (Eq,Ord,Data,Typeable,Generic,Show)
+deriving anyclass instance FromJSON   Email
+deriving anyclass instance ToJSON     Email
+instance FormI.FromHttpApiData Email where parseUrlPiece = fmap Email . FormI.parseUrlPiece
+deriving newtype instance FromField  Email
+deriving newtype instance ToField    Email
+instance StringConv Email [Char] where strConv l (Email sl) = strConv l sl
+instance StringConv Email Text   where strConv l (Email sl) = strConv l sl
+
+instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Email ': rest) where
+  toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
+
+defaultAdminUser :: NewUser
+defaultAdminUser = NewUser { role = Admin
+                           , trust = 100
+                           , nick = Nick "admin"
+                           , email = Email "admin@dev.null"
+                           , password = HashedPassword "admin"}
+
+-- * From here everything is just boilerplate
+newtype HashedPassword =
+  HashedPassword Text
+  deriving (Eq,Ord,Data,Typeable,Generic,Show)
+deriving anyclass instance FromJWT HashedPassword
+deriving anyclass instance ToJWT HashedPassword
+deriving anyclass instance FromJSON   HashedPassword
+deriving anyclass instance ToJSON     HashedPassword
+deriving newtype instance FromField  HashedPassword
+deriving newtype instance ToField    HashedPassword
+instance FormI.FromHttpApiData HashedPassword where parseUrlPiece = fmap HashedPassword . FormI.parseUrlPiece
+instance StringConv HashedPassword [Char]     where strConv l (HashedPassword sl) = strConv l sl
+instance StringConv HashedPassword Text       where strConv l (HashedPassword sl) = strConv l sl
+instance StringConv HashedPassword ByteString where strConv l (HashedPassword sl) = strConv l sl
+instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (HashedPassword ': rest) where
+  toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
+
+
+-- For HTTP
+deriving anyclass instance ToJSON NewUser
+deriving anyclass instance FromJSON NewUser
+
+deriving instance FromJWT NewUser
+deriving instance ToJWT NewUser
+
+-- For Store / SQLite
+instance SOP.Generic NewUser
+instance SOP.HasDatatypeInfo NewUser
+deriving instance SQLiteSchemas NewUser
+instance FromRow NewUser where fromRow = SQL.genericFromRow
+instance ToRow NewUser where toRow = SQL.genericToRow
+
+type User = Entity DefaultMetas NewUser
+
+
+-- *** Field UserId
+newtype UserId   = UserId Text    deriving (Eq,Ord,Show,Generic,Data)
+instance StringConv UserId [Char] where strConv l (UserId sl) = strConv l sl
+instance StringConv UserId Text   where strConv l (UserId sl) = strConv l sl
+deriving anyclass instance FromJSON  UserId
+deriving anyclass instance ToJSON    UserId
+deriving newtype instance FromField UserId
+deriving newtype instance ToField UserId
+instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (UserId ': rest) where
+  toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
+instance FormI.FromHttpApiData UserId where
+  parseUrlPiece = fmap UserId . FormI.parseUrlPiece

src/Aggreact/Users/Views.hs

@@ -0,0 +1,175 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DuplicateRecordFields      #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
+
+{-# LANGUAGE BlockArguments             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE ExplicitForAll             #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedWildCards             #-}
+{-# LANGUAGE NoImplicitPrelude          #-}
+{-# LANGUAGE NumericUnderscores         #-}
+{-# LANGUAGE OverloadedLists            #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE PartialTypeSignatures      #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+
+{- |
+Module      : Aggreact.Users.Views
+Description : User
+Copyright   : (c) 2018, Yann Esposito
+License     : ISC
+Maintainer  : yann.esposito@gmail.com
+Stability   : experimental
+Portability : POSIX
+
+Provide a Store abstraction.
+
+-}
+
+module Aggreact.Users.Views
+
+where
+
+import           Protolude
+
+import           Aggreact.Html                    (boilerplate, cvt, urlEncode)
+import           Aggreact.Users.StoreService
+import           Aggreact.Users.Types
+
+import           Data.Aeson                       (ToJSON (..))
+import qualified Data.UUID                        as UUID
+import           Database.Store
+import           Database.Store.Backend.SQLite    (SearchQuery (Filter))
+import qualified Database.Store.Backend.SQLite    as SQL
+import           Servant
+import           Servant.Errors                   as Err
+import           Text.Blaze.Html5                 ((!))
+import qualified Text.Blaze.Html5                 as H
+import qualified Text.Blaze.Html5.Attributes      as A
+
+data UserPage =
+  UserPage
+  { user  :: User
+  , muser :: Maybe User
+  }
+
+instance ToJSON UserPage where
+  toJSON = toJSON . (user :: UserPage -> User)
+
+instance H.ToMarkup UserPage where
+  toMarkup UserPage{..} = boilerplate (loginWidget muser) $ do
+    let n = toS (nick (val user))
+    H.h2 $
+      H.a ! A.href ("/users/" <> cvt (urlEncode n)) $ H.text (toS n)
+    showUser user
+
+showUser :: User -> H.Markup
+showUser user = do
+  let cid = UUID.toString (toS (id user))
+      nu = val user
+  H.div $ do
+    H.label "nick"
+    H.text (toS (nick nu))
+  H.div $ do
+    H.label "id"
+    H.text (toS cid)
+  H.div $ do
+    H.label "created"
+    H.text (show (created (metas user)))
+  H.div $ do
+    H.label "email"
+    H.text (toS (email (val user)))
+  H.div $ do
+    H.label "role"
+    H.text (show (role (val user)))
+
+-- DELETE User
+data UserDeletedPage =
+  UserDeletedPage
+  { deleted     :: Bool
+  , deletedUser :: User
+  , muser       :: Maybe User
+  }
+
+instance ToJSON UserDeletedPage where
+  toJSON = toJSON . deletedUser
+
+instance H.ToMarkup UserDeletedPage where
+  toMarkup UserDeletedPage{..} = boilerplate (loginWidget muser) $ do
+    let n = toS (nick (val deletedUser))
+    H.h2 $
+      H.text ("User " <> n <> if deleted then " was deleted" else " couldn't be deleted!")
+
+deleteUserById :: Maybe User -- ^ Logged User
+               -> UserHandler
+               -> Id -- ^ User id to delete
+               -> Handler UserDeletedPage
+deleteUserById Nothing _ _ = unauthorized "Only admins can delete users"
+deleteUserById (Just u) userHandler userId
+  | role (val u) == Admin = do
+      userToDelete <- liftIO $ readUser userHandler userId
+      case userToDelete of
+        Nothing -> notFound "User not found!"
+        Just utd -> UserDeletedPage
+                    <$> liftIO (deleteUser userHandler userId)
+                    <*> pure utd
+                    <*> pure (Just u)
+  | otherwise = forbidden "Only admins can delete users"
+
+loginWidget :: Maybe User -> H.Markup
+loginWidget Nothing                = H.a ! A.href "/login" $ H.text "Login"
+loginWidget (Just (Entity _ nu _)) = H.a ! A.href ("/users/" <> cvt (nick nu)) $ H.text (toS (nick nu))
+
+-- List Users
+data UsersPage =
+  UsersPage
+  { users :: [User]
+  , muser :: Maybe User
+  }
+
+instance ToJSON UsersPage where
+  toJSON = toJSON . users
+
+instance H.ToMarkup UsersPage where
+  toMarkup UsersPage{..} = boilerplate (loginWidget muser) $ do
+    H.h2 $ H.text "Users"
+    traverse_ (\u -> showUser u >> H.hr) users
+
+listUsers :: Maybe User -> UserHandler -> Handler UsersPage
+listUsers muser userHandler = do
+  SQL.SR (SQL.Paginated mu _ _) <- liftIO $
+    searchUsers userHandler Filter {params = []}
+  pure (UsersPage mu muser)
+
+-- Create User
+data RegisteredUserPage =
+  RegisteredUsersPage
+  { user  :: User
+  , muser :: Maybe User
+  }
+
+instance ToJSON RegisteredUserPage where
+  toJSON = toJSON . (user :: RegisteredUserPage -> User)
+
+instance H.ToMarkup RegisteredUserPage where
+  toMarkup RegisteredUsersPage{..} = boilerplate (loginWidget muser) $ do
+    H.h2 $ H.text "Users"
+    showUser user
+
+postUser :: Maybe User
+         -> UserHandler
+         -> NewUser
+         -> Handler RegisteredUserPage
+postUser muser userHandler nu = do
+  u <- liftIO $ createUser userHandler nu
+  pure (RegisteredUsersPage u muser)