I guess the question is, since there’s obvious code replication, and in the full section this operator function is used like 20 times, what would be a better name for this overloaded function? Or would the code replication be considered useful for readability?
Also, here’s the full code snippet. I’m going to be refactoring it soon because you’re seeing an obvious use case for -XNonDecreasingIndentation, but I don’t want to either resort to throwing exceptions, using ExceptT, or dragging in Bluefin (sorry @tomjaguarpaw !).
The obvious change would be to have the exception handling code exist on the top level, but the particular database calls and encipherments should exist instead in the where block or in independent floating functions on the top level.
{-# LANGUAGE OverloadedStrings, DuplicateRecordFields, RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Geta.Login.CreateUser
( createUser
, createUser'
, createUserWithConnection
, createUserWithConnection'
, CreateUserDBList (..)
, defaultCreateUser
, CreateUserError
) where
-- Base imports
import Data.Functor.Contravariant (contramap)
import Data.Foldable (fold)
import Data.Bifunctor (first)
-- Reimports from the library.
import Geta.Login.Reexports (EmailAddress)
import Geta.Login.Reexports qualified as Reexports
import Geta.Login.Utils.Internal (toHexText, argon2HashPassword)
-- Quasi-standard Haskell type imports.
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.ByteString (ByteString)
-- Hasql imports
import Hasql.Session qualified as Session
import Hasql.Pipeline qualified as Pipeline
import Hasql.Statement qualified as Statement
import Hasql.Encoders qualified as Encoders
import Hasql.Decoders qualified as Decoders
import Hasql.Connection (Connection)
-- Crypton imports
import Crypton.Error qualified as CryptonError
newtype CreateUserError = MkCreateUserError
(Either
CryptonError
Session.SessionError
)
deriving Show
data CreateUserDBList = MkCreateUserDBList
{ usersDB :: Text
, emailsDB :: Text
, creationTimesDB :: Text
, validationKeysDB :: Text
, userStatusDB :: Text
} deriving Show
defaultCreateUser :: CreateUserDBList
defaultCreateUser = MkCreateUserDBList
{ usersDB = "users"
, emailsDB = "user_emails"
, creationTimesDB = "user_creation_times"
, validationKeysDB = "user_activation_keys"
, userStatusDB = "user_status"
}
createUser :: a
createUser = undefined
createUser' :: a
createUser' = undefined
{-| Variant of createUser that allows providing your own connection. -}
createUserWithConnection
:: Connection -- ^ Hasql connection.
-> Text -- ^ Username
-> Text -- ^ Password
-> EmailAddress -- ^ E-mail address formatted via email-validate's
-- functions, see Geta.Login.Reexports
-> IO (Either CreateUserError Text)
createUserWithConnection = createUserWithConnection' defaultCreateUser
{-| Variant of createUserWithConnection that allows specification of
databases in use. Actually the worker function of that function. -}
createUserWithConnection'
:: CreateUserDBList -- ^ Record type holding DB fields.
-> Connection -- ^ Hasql connection.
-> Text -- ^ Username
-> Text -- ^ Password
-> EmailAddress -- ^ E-mail address formatted via email-validate's
-- functions, see Geta.Login.Reexports
-> IO (Either CreateUserError Text)
createUserWithConnection'
MkCreateUserDBList {..}
conn
username
password
email = do
-- First section creates the uuid that pins the rest
-- of the IO function tegether.
saltResult <- convertCryptonError undefined
mapM saltResult \(hashedPassword, passwordSalt) -> do
uidOrErr <- convertHasqlError $ flip Session.run conn
$ Session.statement
(usersDB, username, hashedPassword, passwordSalt)
$ Statement.Statement
"INSERT INTO $1 VALUES \
\(DEFAULT, $2 , $3 , $4 ) \
\RETURNING uid;"
do fold [ Encoders.text @ \(a,_,_,_) -> a
, Encoders.text @ \(_,b,_,_) -> b
, Encoders.bytea @ \(_,_,c,_) -> c
, Encoders.bytea @ \(_,_,_,d) -> d
]
do Decoders.singleRow
$ Decoders.column
$ Decoders.nonNullable
$ Decoders.uuid
False
-- Create the other database entries for the new user, acting upon the
-- result of the previous function. If an error is thrown by the first
-- action, mapM will cause an abort and propagate the error.
mapM uidOrErr \uuid -> do
-- Use IO to generate the random seed.
validationKey <- undefined
-- Commit the other transactions through a pipeline, returning a
-- hex-encoded version of the validation key if successful.
fmap ( const $ toHexText validationKey )
$ flip Session.run conn
$ Session.pipeline
$ do Pipeline.statement (creationTimesDB, uuid)
$ dynStatementNoRes
"INSERT INTO $1 VALUES \
\( $2 , DEFAULT );"
$ Encoders.text @ fst
<> Encoders.uuid @ snd
*> do Pipeline.statement (userStatusDB, uuid)
$ dynStatementNoRes
"INSERT INTO $1 VALUES \
\( $2 , DEFAULT );"
$ Encoders.text @ fst
<> Encoders.uuid @ snd
*> do Pipeline.statement ( emailsDB
, uuid
, decodeUtf8
$ Reexports.toByteString
email
)
$ dynStatementNoRes
"INSERT INTO $1 VALUES \
\( $2 , $3 );"
$ fold [ Encoders.text @ \(a,_,_) -> a
, Encoders.uuid @ \(_,b,_) -> b
, Encoders.text @ \(_,_,c) -> c
]
*> do Pipeline.statement (validationKeysDB, uuid, authHash)
$ dynStatementNoRes
"INSERT INTO $1 VALUES \
\( $2 , $3 );"
$ fold [ Encoders.text @ \(a,_,_) -> a
, Encoders.uuid @ \(_,b,_) -> b
, Encoders.bytea @ \(_,_,c) -> c
]
where
-- | Helper operator to avoid retyping a complex conversion
--
(@) encoder selector = contramap selector $ Encoders.param
$ Encoders.nonNullable encoder
infix 8 @
convertCryptonError = first ( MkCreateUserError . Left )
convertHasqlError = first ( MkCreateUserError . Right )
-- | Statement for pipeline with constant arguments preapplied.
dynStatementNoRes sql encoder =
Statement.Statement sql encoder Decoders.noResult False