I'm doomed to perdition for this, aren't I? Or the operator equivalent of go

do let encoder @ selector = contramap selector $ Encoders.param
            $ Encoders.nonNullable encoder
   fold [ Encoders.text  @ \(a,_,_) -> a
        , Encoders.bytea @ \(_,b,_) -> b
        , Encoders.bytea @ \(_,_,c) -> c
        ]

Context:

This is currently a half-completed code sample, but I’m wondering whether people DO use operators for this kind of application (reducing code replication), and if so, whether there’s a standard operator for this just as much as go is standard for helpers with function names.

@ is used mainly for asPatterns, so it doesn’t show up on Stackage@Hoogle, and the same applies to ~, which tends to be reserved for irrefutable patterns.

And yes, I’m doomed to double-triple perdition, because not only am I abusing operators for code-golfing purposes, I’m also abusing do-bulletting (this is a one-liner with a let using the do to scope the operator into existence only within the do).

2 Likes

I personally wouldn’t do this, and would likely trip over it in a code review and then ask you about it. I’d probably also end up asking you to consider let .. in .. over do let because I try hard to only use do where something bind-like is going on. There have been some occasional tricks posted that use do and I think -XBlockArguments to reduce the number of parens needed to express some code, I think mostly when dealing with complicated Applicative expressions where -XApplicativeDo does not apply for some reason, but I don’t think they caught on.

ISTM that the main benefit of your operator is that it’s letting you put a lambda on the RHS of your expression. I’d definitely endorse naming a local function for that, but in this instance I’d also be happy to lean on lens:

fold [ view _1 >$< Encoders.param (Encoders.nonNullable Encoders.text)
     , view _2 >$< Encoders.param (Encoders.nonNullable Encoders.bytea)
     , view _3 >$< Encoders.param (Encoders.nonNullable Encoders.bytea)
     ]

As for the @ sigil specifically, I see it sometimes used for application constructors or functions when writing lambda calculus stuff — there’s a lot of historical precedent for that. But usually it’s something like @@ or the :@ constructor, which makes it clear that it’s not an as-pattern.

2 Likes

I don’t see anything strange with the snippet per se, but surprising that the @ used as an inline operator even typechecks.

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

We started doing all that encoders / decoders dance for a while until we decided to switch to using hasql-th. It significantly decreased the boilerplate and made things obvious.

1 Like

The intended application is FOSS “this is a stupid simple library that compiles quickly”, that becomes a standard for “I need a backend login system, and am willing to put up with mildly suboptimal defaults in return for convenience”. This is after me spending 2 weeks trying to figure out how to set up a login system for a website prototype I want to make.

3 Likes