Initial commit

.gitignore

@@ -0,0 +1,24 @@
+dist*
+static/tmp/
+static/combined/
+*.hi
+*.o
+*.sqlite3
+*.sqlite3-shm
+*.sqlite3-wal
+.hsenv*
+cabal-dev/
+.stack-work/
+.stack-work-devel/
+yesod-devel/
+.cabal-sandbox
+cabal.sandbox.config
+.DS_Store
+*.swp
+*.keter
+*~
+\#*
+interdimensional.cabal
+config.yml
+img/*
+*.iml

README.md

@@ -0,0 +1,3 @@
+# interndimensional
+
+A portal to your applications.

app/devel.hs

@@ -0,0 +1,6 @@
+{-# LANGUAGE PackageImports #-}
+import "interdimensional" Application (appMain)
+import Prelude (IO)
+
+main :: IO ()
+main = appMain

app/main.hs

@@ -0,0 +1,5 @@
+import Prelude     (IO)
+import Application (appMain)
+
+main :: IO ()
+main = appMain

package.yaml

@@ -0,0 +1,110 @@
+name:    interdimensional
+version: "0.1.0"
+
+dependencies:
+
+- base >=4.9.1.0 && <5
+- yesod >=1.6 && <1.7
+- yesod-core >=1.6 && <1.7
+- yesod-auth >=1.6 && <1.7
+- yesod-static >=1.6 && <1.7
+- yesod-form >=1.6 && <1.7
+- classy-prelude >=1.5 && <1.6
+- classy-prelude-conduit >=1.5 && <1.6
+- classy-prelude-yesod >=1.5 && <1.6
+- bytestring >=0.10 && <0.11
+- text >=0.11 && <2.0
+- persistent >=2.9 && <2.11
+- persistent-sqlite >=2.9 && <2.11
+- persistent-template >=2.5 && <2.9
+- template-haskell
+- shakespeare >=2.0 && <2.1
+- hjsmin >=0.1 && <0.3
+- monad-control >=0.3 && <1.1
+- wai-extra >=3.0 && <3.1
+- yaml >=0.11 && <0.12
+- http-client-tls >=0.3 && <0.4
+- http-conduit >=2.3 && <2.4
+- directory >=1.1 && <1.4
+- warp >=3.0 && <3.4
+- data-default
+- aeson >=1.4 && <1.5
+- conduit >=1.0 && <2.0
+- monad-logger >=0.3 && <0.4
+- fast-logger >=2.2 && <3.1
+- wai-logger >=2.2 && <2.4
+- file-embed
+- safe
+- unordered-containers
+- containers
+- vector
+- time
+- case-insensitive
+- wai
+- foreign-store
+- process
+- directory-tree
+- aeson
+- yesod-auth-oauth2
+- yaml
+- uri-bytestring
+- uri-bytestring-aeson
+- lens-aeson
+- microlens
+- lens
+
+# The library contains all of our application code. The executable
+# defined below is just a thin wrapper.
+library:
+  source-dirs: src
+  when:
+  - condition: (flag(dev)) || (flag(library-only))
+    then:
+      ghc-options:
+      - -Wall
+      - -fwarn-tabs
+      - -O0
+      cpp-options: -DDEVELOPMENT
+    else:
+      ghc-options:
+      - -Wall
+      - -fwarn-tabs
+      - -O2
+
+# Runnable executable for our application
+executables:
+  interdimensional:
+    main: main.hs
+    source-dirs: app
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - interdimensional
+    when:
+    - condition: flag(library-only)
+      buildable: false
+
+# Test suite
+tests:
+  interdimensional-test:
+    main: Spec.hs
+    source-dirs: test
+    ghc-options: -Wall
+    dependencies:
+    - interdimensional
+    - hspec >=2.0.0
+    - yesod-test
+    - microlens
+
+# Define flags used by "yesod devel" to make compilation faster
+flags:
+  library-only:
+    description: Build for use with "yesod devel"
+    manual: false
+    default: false
+  dev:
+    description: Turn on development settings, like auto-reload templates.
+    manual: false
+    default: false

src/Application.hs

@@ -0,0 +1,132 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Application where
+
+import ClassyPrelude.Yesod (ReaderT, fromString, newManager, pack, runMigration, unpack, (</>))
+import Data.Yaml.Aeson (decodeFileEither)
+import GenericOIDC (oidcAuth')
+import System.Directory (createDirectoryIfMissing)
+import Text.Cassius
+import Text.Julius
+import URI.ByteString ()
+import InterdimensionalConfig
+import Yesod
+import Yesod.Auth
+import Yesod.Auth.OAuth2.Prelude
+import Yesod.Form.Bootstrap3
+import Yesod.Static
+import Prelude
+
+data Interdimensional = Interdimensional
+  { httpManager :: Manager,
+    config :: InterdimensionalConfig,
+    getStatic :: Static
+  }
+
+mkYesod
+  "Interdimensional"
+  [parseRoutes|
+/auth                  AuthR Auth getAuth
+/                      HomeR GET
+|]
+
+css :: p -> Css
+css =
+  [cassius|
+body
+  margin: 40px auto
+  max-width: 650px
+  line-height: 1.6
+  font-size: 18px
+  color: #444
+  padding: 0 10px
+h1, h2, h3
+  line-height: 1.2
+|]
+
+footer :: WidgetFor Interdimensional ()
+footer = [whamlet|
+<p>
+  <a href=@{HomeR}>Home</a>
+|]
+
+instance Yesod Interdimensional where
+  approot = ApprootMaster $ host . config
+  authRoute _ = Just $ AuthR LoginR
+
+  isAuthorized _ _ = return Authorized
+
+isSignedIn :: HandlerFor Interdimensional AuthResult
+isSignedIn = do
+  user <- maybeAuthId
+  return $ case user of
+    Nothing -> AuthenticationRequired
+    Just _ -> Authorized
+
+instance YesodAuth Interdimensional where
+  type AuthId Interdimensional = Text
+  authenticate = return . Authenticated . credsIdent
+  loginDest _ = HomeR
+  logoutDest _ = HomeR
+  authPlugins y = [oidcAuth' $ oidc $ config y]
+  maybeAuthId = lookupSession "_ID"
+
+instance RenderMessage Interdimensional FormMessage where
+  renderMessage _ _ = defaultFormMessage
+
+getHomeR :: Handler Html
+getHomeR = do
+  user <- maybeAuthId
+  mmsg <- getMessage
+  defaultLayout
+    [whamlet|
+          ^{css}
+          <h1>Welcome to Interdimensional!
+          <p>Interdimensional is a free application portal, made for homelabs. It lets users see what applications
+            they can access, via OpenID Connect.
+          <p>It is written in 
+            <a href="https://www.haskell.org/">Haskell
+            and uses the 
+            <a href="https://www.yesodweb.com/">Yesod
+            web framework. You can find the source code
+            <a href="https://github.com/dfsek/interdimensional">Here</a>.
+            Enjoy!
+          $maybe un <- user
+            <p>Logged in as #{un}
+            <p>
+              <a href=@{AuthR LogoutR}>Log out
+          $nothing
+            <p>
+              <a href=@{AuthR LoginR}>Log in
+          $maybe msg <- mmsg
+            <p>#{msg}
+          ^{footer}
+        |]
+
+
+appMain :: IO ()
+appMain = do
+  c' <- decodeFileEither "config.yml"
+  case c' of
+    Left e -> error $ "Could not parse config file: " <> show e
+    Right conf -> do
+      let contentDir = static_dir conf
+      createDirectoryIfMissing True contentDir
+      putStrLn $ "Serving static content from " <> contentDir
+
+      staticRoute <- static contentDir
+      putStrLn $ "Launching application at " <> show (host conf)
+
+      manager <- newManager
+
+      warp 3001 $ Interdimensional manager conf staticRoute

src/Apps.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Apps (AppConfig (..), AccessConfig (..)) where
+
+import ClassyPrelude.Conduit (Text)
+import Data.Yaml (FromJSON)
+import GHC.Generics (Generic)
+import URI.ByteString (Absolute, URIRef)
+import URI.ByteString.Aeson ()
+
+data AccessConfig
+  = PublicApp
+      {}
+  | AuthenticatedApp
+      {role :: Text}
+  deriving (Eq, Show, FromJSON, Generic)
+
+data AppConfig = AppConfig
+  { name :: Text,
+    app_uri :: URIRef Absolute,
+    image_path :: Maybe Text,
+    source_uri :: URIRef Absolute,
+    description :: Text,
+    access :: AccessConfig
+  }
+  deriving (Eq, Show, FromJSON, Generic)

src/GenericOIDC.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GenericOIDC (oidcAuth, oidcAuth') where
+
+import ClassyPrelude.Yesod (WidgetFor, whamlet)
+import Data.ByteString.Lazy (ByteString)
+import Network.OAuth.OAuth2.Compat (authGetBS)
+import InterdimensionalConfig
+import qualified Yesod.Auth.OAuth2.Exception as YesodOAuth2Exception
+import Yesod.Auth.OAuth2.Prelude
+import Data.Aeson (Value)
+import Data.Aeson.Lens
+import Data.Text (unpack, splitOn)
+import Prelude
+import Lens.Micro ((^?))
+import Control.Lens (Prism')
+
+
+oidcAuth' :: YesodAuth m => OIDCConfig -> AuthPlugin m
+oidcAuth' config = oidcAuth [whamlet|Login with #{plugin_name config}|] config
+
+oidcAuth :: YesodAuth m => WidgetFor m () -> OIDCConfig -> AuthPlugin m
+oidcAuth widget config =
+  let pluginName = plugin_name config in
+  authOAuth2Widget widget pluginName oauth2 $ \manager token -> do
+    resp <- authGetBS manager (accessToken token) (user_info config)
+    userResponse <- fromAuthGet pluginName resp
+    json <- decodeAuthJSON pluginName userResponse :: IO Value
+
+    print json
+
+    print $ fromQuery "resource_access" id json
+    print $ fromQuery "preferred_username" _String json
+    print $ fromQuery "resource_access.interdimensional" id json
+    print $ fromQuery "resource_access.interdimensional.roles" id json
+
+    let unKey = username_attribute config
+
+    username <- case fromQuery "preferred_username" _String json of
+      Nothing -> throwIO $ YesodOAuth2Exception.JSONDecodingError pluginName ("No such key " <> show unKey <> " in response.")
+      Just s -> return s
+
+    putStrLn $ "Username: " <> unpack username
+
+    pure
+      Creds
+        { credsPlugin = pluginName,
+          credsIdent = username,
+          credsExtra = setExtra token userResponse
+        }
+  where
+    oauth2 =
+      OAuth2
+        { oauth2ClientId = client_id config,
+          oauth2ClientSecret = Just $ secret config,
+          oauth2AuthorizeEndpoint = auth_url config `withQuery` [ scopeParam " " ["openid", "roles", "profile", "phone"]],
+          oauth2TokenEndpoint = token_url config,
+          oauth2RedirectUri = Nothing
+        }
+
+fromQuery :: Text -> Prism' Value a -> Value -> Maybe a
+fromQuery string get = (^? foldl append id tokens . get) where
+  tokens = splitOn "." string
+  append f token = f . key token
+
+fromAuthGet :: Text -> Either ByteString ByteString -> IO ByteString
+fromAuthGet _ (Right bs) = pure bs -- nice
+fromAuthGet name (Left err) =
+  throwIO $ YesodOAuth2Exception.OAuth2Error name err
+
+decodeAuthJSON :: Text -> ByteString -> IO Value
+decodeAuthJSON name resp =
+  case eitherDecode resp of
+    Left err -> throwIO $ YesodOAuth2Exception.JSONDecodingError name err
+    Right json -> return json
+

src/InterdimensionalConfig.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module InterdimensionalConfig (OIDCConfig (..), InterdimensionalConfig (..)) where
+
+import Apps (AppConfig)
+import ClassyPrelude.Conduit (Generic)
+import Data.Aeson
+import Data.Text (Text)
+import URI.ByteString
+import URI.ByteString.Aeson ()
+
+data InterdimensionalConfig = InterdimensionalConfig
+  { oidc :: OIDCConfig,
+    host :: Text,
+    static_dir :: String,
+    apps :: [AppConfig]
+  }
+  deriving (Generic, FromJSON)
+
+data OIDCConfig = OIDCConfig
+  { secret :: Text,
+    client_id :: Text,
+    token_url :: URIRef Absolute,
+    auth_url :: URIRef Absolute,
+    user_info :: URIRef Absolute,
+    username_attribute :: Text,
+    plugin_name :: Text
+  }
+  deriving (Generic, FromJSON)

stack.yaml

@@ -0,0 +1,69 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver:
+  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+#   subdirs:
+#   - auto-update
+#   - wai
+packages:
+  - .
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+# extra-deps:
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+extra-deps:
+  - yesod-auth-oauth2-0.7.0.2@sha256:b1dabedb8a22a97d74febd3d76b764596847ad1a5e40dd473ffb5d4098723bf3,3410
+  - image-type-0.1.0.0@sha256:47033c893690f2cea85ba867343f277a8e2594f9010a5466a39dc7f3c4d682f2,1676
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.7"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor

test/Handler/CommentSpec.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Handler.CommentSpec (spec) where
+
+import TestImport
+import Data.Aeson
+
+spec :: Spec
+spec = withApp $ do
+    describe "valid request" $ do
+        it "gives a 200" $ do
+            get HomeR
+            statusIs 200
+
+            let message = "My message" :: Text
+                body = object [ "message" .= message ]
+                encoded = encode body
+
+            request $ do
+                setMethod "POST"
+                setUrl CommentR
+                setRequestBody encoded
+                addRequestHeader ("Content-Type", "application/json")
+
+            statusIs 200
+
+            comments <- runDB $ selectList [CommentMessage ==. message] []
+            Entity _id comment <-
+                case comments of
+                    [ent] -> pure ent
+                    _ -> error "needed 1 entity"
+            assertEq "Should have " comment (Comment message Nothing)
+
+    describe "invalid requests" $ do
+        it "400s when the JSON body is invalid" $ do
+            get HomeR
+
+            let body = object [ "foo" .= ("My message" :: Value) ]
+
+            request $ do
+                setMethod "POST"
+                setUrl CommentR
+                setRequestBody $ encode body
+                addRequestHeader ("Content-Type", "application/json")
+
+            statusIs 400
+

test/Handler/CommonSpec.hs

@@ -0,0 +1,17 @@
+module Handler.CommonSpec (spec) where
+
+import TestImport
+
+spec :: Spec
+spec = withApp $ do
+    describe "robots.txt" $ do
+        it "gives a 200" $ do
+            get RobotsR
+            statusIs 200
+        it "has correct User-agent" $ do
+            get RobotsR
+            bodyContains "User-agent: *"
+    describe "favicon.ico" $ do
+        it "gives a 200" $ do
+            get FaviconR
+            statusIs 200

test/Handler/HomeSpec.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Handler.HomeSpec (spec) where
+
+import TestImport
+
+spec :: Spec
+spec = withApp $ do
+
+    describe "Homepage" $ do
+        it "loads the index and checks it looks right" $ do
+          get HomeR
+          statusIs 200
+          htmlAnyContain "h1" "a modern framework for blazing fast websites"
+
+          request $ do
+              setMethod "POST"
+              setUrl HomeR
+              addToken
+              fileByLabelExact "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference
+              byLabelExact "What's on the file?" "Some Content"
+
+          statusIs 200
+          -- more debugging printBody
+          htmlAllContain ".upload-response" "text/plain"
+          htmlAllContain ".upload-response" "Some Content"
+
+        -- This is a simple example of using a database access in a test.  The
+        -- test will succeed for a fresh scaffolded site with an empty database,
+        -- but will fail on an existing database with a non-empty user table.
+        it "leaves the user table empty" $ do
+          get HomeR
+          statusIs 200
+          users <- runDB $ selectList ([] :: [Filter User]) []
+          assertEq "user table empty" 0 $ length users

test/Handler/ProfileSpec.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Handler.ProfileSpec (spec) where
+
+import TestImport
+
+spec :: Spec
+spec = withApp $ do
+
+    describe "Profile page" $ do
+        it "asserts no access to my-account for anonymous users" $ do
+            get ProfileR
+            statusIs 403
+
+        it "asserts access to my-account for authenticated users" $ do
+            userEntity <- createUser "foo"
+            authenticateAs userEntity
+
+            get ProfileR
+            statusIs 200
+
+        it "asserts user's information is shown" $ do
+            userEntity <- createUser "bar"
+            authenticateAs userEntity
+
+            get ProfileR
+            let (Entity _ user) = userEntity
+            htmlAnyContain ".username" . unpack $ userIdent user

test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

test/TestImport.hs

@@ -0,0 +1,103 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module TestImport
+    ( module TestImport
+    , module X
+    ) where
+
+import Application           (makeFoundation, makeLogWare)
+import ClassyPrelude         as X hiding (delete, deleteBy, Handler)
+import Database.Persist      as X hiding (get)
+import Database.Persist.Sql  (SqlPersistM, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName)
+import Foundation            as X
+import Model                 as X
+import Test.Hspec            as X
+import Yesod.Default.Config2 (useEnv, loadYamlSettings)
+import Yesod.Auth            as X
+import Yesod.Test            as X
+import Yesod.Core.Unsafe     (fakeHandlerGetLogger)
+
+-- Wiping the database
+import Database.Persist.Sqlite              (sqlDatabase, mkSqliteConnectionInfo, fkEnabled, createSqlitePoolFromInfo)
+import Control.Monad.Logger                 (runLoggingT)
+import Lens.Micro                           (set)
+import Settings (appDatabaseConf)
+import Yesod.Core (messageLoggerSource)
+
+runDB :: SqlPersistM a -> YesodExample App a
+runDB query = do
+    pool <- fmap appConnPool getTestYesod
+    liftIO $ runSqlPersistMPool query pool
+
+runHandler :: Handler a -> YesodExample App a
+runHandler handler = do
+    app <- getTestYesod
+    fakeHandlerGetLogger appLogger app handler
+
+withApp :: SpecWith (TestApp App) -> Spec
+withApp = before $ do
+    settings <- loadYamlSettings
+        ["config/test-settings.yml", "config/settings.yml"]
+        []
+        useEnv
+    foundation <- makeFoundation settings
+    wipeDB foundation
+    logWare <- liftIO $ makeLogWare foundation
+    return (foundation, logWare)
+
+-- This function will truncate all of the tables in your database.
+-- 'withApp' calls it before each test, creating a clean environment for each
+-- spec to run in.
+wipeDB :: App -> IO ()
+wipeDB app = do
+    -- In order to wipe the database, we need to use a connection which has
+    -- foreign key checks disabled.  Foreign key checks are enabled or disabled
+    -- per connection, so this won't effect queries outside this function.
+    --
+    -- Aside: foreign key checks are enabled by persistent-sqlite, as of
+    -- version 2.6.2, unless they are explicitly disabled in the
+    -- SqliteConnectionInfo.
+
+    let logFunc = messageLoggerSource app (appLogger app)
+
+    let dbName = sqlDatabase $ appDatabaseConf $ appSettings app
+        connInfo = set fkEnabled False $ mkSqliteConnectionInfo dbName
+
+    pool <- runLoggingT (createSqlitePoolFromInfo connInfo 1) logFunc
+
+    flip runSqlPersistMPool pool $ do
+        tables <- getTables
+        sqlBackend <- ask
+        let queries = map (\t -> "DELETE FROM " ++ (connEscapeName sqlBackend $ DBName t)) tables
+        forM_ queries (\q -> rawExecute q [])
+
+getTables :: DB [Text]
+getTables = do
+    tables <- rawSql "SELECT name FROM sqlite_master WHERE type = 'table';" []
+    return (fmap unSingle tables)
+
+-- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag
+-- being set in test-settings.yaml, which enables dummy authentication in
+-- Foundation.hs
+authenticateAs :: Entity User -> YesodExample App ()
+authenticateAs (Entity _ u) = do
+    request $ do
+        setMethod "POST"
+        addPostParam "ident" $ userIdent u
+        setUrl $ AuthR $ PluginR "dummy" []
+
+-- | Create a user.  The dummy email entry helps to confirm that foreign-key
+-- checking is switched off in wipeDB for those database backends which need it.
+createUser :: Text -> YesodExample App (Entity User)
+createUser ident = runDB $ do
+    user <- insertEntity User
+        { userIdent = ident
+        , userPassword = Nothing
+        }
+    _ <- insert Email
+        { emailEmail = ident
+        , emailUserId = Just $ entityKey user
+        , emailVerkey = Nothing
+        }
+    return user