digestive-functors

df.hs

data LoginF = LoginF String String
login :: Application ()
login = do
  fx <- eitherSnapForm login_form "login-form"
  case fx of
    Left s -> heistLocal (bindSplices s) $ render "login"
    Right (LoginF email passw) -> do
      us <- account_by_email $ B.pack email
      maybe e404 ((huser $ B.pack passw) . snd) us
 where
   huser orig user = do
     case (accountPass user) == (B.pack $ shain orig) of
       False -> e404
       True -> do
         modifyResponse $ addCookie $
           Cookie "uid" (accountUid user)
             Nothing Nothing (Just "/")
         redirect "/"
   account_by_email us =
     liftIO $ runQ "test.db" $ getBy $ AEmail us
   login_form :: SnapForm Application T.Text HeistView LoginF
   login_form =
     LoginF <$> input "email" Nothing `validate` check_length <++ errors
     <*> input "pass" Nothing `validate` check_length <++ errors