Main.hs

data ApiInfo = ApiInfo {
  name :: T.Text,
  version :: T.Text
} deriving (Eq, Generic)

instance FromJSON ApiInfo
instance ToJSON ApiInfo

data Config = Config {
   info :: ApiInfo
   , dbHost :: HostName
   , port :: Int
   }

data TnConfig = TnConfig {
    pool :: (Pool RethinkDBHandle)
    , config :: Config
    }

data TnOptions = TnOptions {
    env :: String
    } deriving (Data,Typeable)

type TnIO = ReaderT TnConfig IO

type API = Get '[JSON] ApiInfo
    :<|> "users" :> Get '[JSON] [SecureUser]
    :<|> "users" :> ReqBody '[JSON] UserSignup :> Post '[JSON] SecureUser

api :: Proxy API
api = Proxy

serverT :: TnConfig -> ServerT API TnIO
serverT t = getApiInfo
    :<|> getUsers
    :<|> postUsers
    where
        getApiInfo :: TnIO ApiInfo
        getApiInfo = apiInfo

        getUsers :: TnIO [SecureUser]
        getUsers = list

        postUsers :: UserSignup -> TnIO SecureUser
        postUsers u = do
            -- Given that eitherU is TnIO (Either Text SecureUser)
            -- How do I return the error here?
            eitherU <- create u
            return $ fromRight eitherU

readerToEither' :: TnConfig -> forall a. TnIO a -> EitherT ServantErr IO a
-- Does this ignore Left?
readerToEither' t r = EitherT (fmap Right (runReaderT r t))

readerToEither :: TnConfig -> TnIO :~> EitherT ServantErr IO
readerToEither t = Nat $ readerToEither' t

User.hs

create :: UserSignup -> TnIO (Either Text SecureUser)
create u = do
    let pass = US.password u
    if pass == (US.passwordConfirmation u)
      then do
        isEmail <- findByEmail $ US.email u
        user <- newUser u pass
        case listToMaybe isEmail of
          Nothing -> do
            r <- runDB $ U.table # ex insert [returnChanges] (toDatum user)
            case (writeChangeNew r :: Maybe User) of
                Nothing -> return $ Left "Database error"
                Just x -> return . Right $ U.SecureUser x
          Just _-> return $ Left "User already exists with that email"
    else return $ Left "Password and Password Confirmation do not match"

newUser :: UserSignup -> Text -> TnIO User
newUser u p = do
    uId <- liftIO nextRandom
    hashPass <- liftIO . hashPasswordUsingPolicy customHashPolicy . fromString $ unpack p
    createdAt <- liftIO getCurrentTime
    token <- liftIO randomString
    return $ User {
        U.id = uId
        , firstName = US.firstName u
        , lastName = US.lastName u
        , email = US.email u
        , hashedPassword = pack $ toString $ fromJust hashPass
        , apiKeys = [pack token]
        , createdAt = createdAt
        , updatedAt = createdAt
        }