1 {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
    2 module Databrary.Controller.Form
    3   ( FormData
    4   , DeformHandler
    5   , runFormFiles
    6   , runForm
    7   , blankForm
    8 
    9   , emailTextForm
   10   , passwordForm
   11   , paginateForm
   12   , csrfForm
   13   ) where
   14 
   15 import Control.Applicative ((<|>))
   16 import Control.Monad (unless)
   17 import Control.Monad.IO.Class (liftIO)
   18 import Control.Monad.Reader (ask)
   19 import Control.Monad.Trans.Class (lift)
   20 import qualified Crypto.BCrypt as BCrypt
   21 import qualified Data.Aeson as JSON
   22 import qualified Data.ByteString as BS
   23 import qualified Data.ByteString.Char8 as BSC
   24 import Data.Char (toLower)
   25 import Data.Monoid ((<>))
   26 import qualified Data.Text.Encoding as TE
   27 import Data.Word (Word64)
   28 import Network.HTTP.Types (badRequest400)
   29 import qualified Text.Blaze.Html5 as Html
   30 import qualified Text.Regex.Posix as Regex
   31 
   32 import Databrary.Has
   33 import Databrary.Model.Paginate
   34 import Databrary.Model.Party
   35 import Databrary.Model.Identity
   36 import Databrary.Service.Passwd
   37 import Databrary.HTTP.Parse (FileContent)
   38 import Databrary.HTTP.Form (FormData)
   39 import Databrary.HTTP.Form.Deform
   40 import Databrary.HTTP.Form.View (runFormView, blankFormView)
   41 import Databrary.HTTP.Form.Errors (FormErrors)
   42 import Databrary.Action.Response
   43 import Databrary.Action.Types
   44 import Databrary.Action.Form (getFormData)
   45 import Databrary.Controller.Permission (checkVerfHeader)
   46 import Databrary.View.Form (FormHtml)
   47 
   48 -- FIXME: This is too impure: each value of this type should be decomposed separately
   49 -- into a DeformT and an Handler e.g. deformT ... >>= \x -> actionM ...
   50 type DeformHandler f a = DeformT f Handler a
   51 
   52 jsonFormErrors :: FormErrors -> Response
   53 jsonFormErrors = response badRequest400 [] . JSON.toEncoding
   54 
   55 htmlFormErrors :: (FormErrors -> Html.Html) -> FormErrors -> Response
   56 htmlFormErrors f = response badRequest400 [] . f
   57 
   58 handleForm :: (FormErrors -> Response) -> Either FormErrors a -> Handler a
   59 handleForm re = either (result . re) return
   60 
   61 handleFormErrors :: Maybe (FormErrors -> Html.Html) -> Either FormErrors a -> Handler a
   62 handleFormErrors = handleForm . maybe jsonFormErrors htmlFormErrors
   63 
   64 runFormWith :: FormData f -> Maybe (RequestContext -> FormHtml f) -> DeformHandler f a -> Handler a
   65 runFormWith fd mf fa = do
   66   req <- ask
   67   let fv hv = runFormView (hv req) fd
   68   handleFormErrors (fv <$> mf) =<< runDeform fa fd
   69 
   70 runFormFiles
   71   :: FileContent f => [(BS.ByteString, Word64)] -> Maybe (RequestContext -> FormHtml f) -> DeformHandler f a -> Handler a
   72 runFormFiles fl mf fa = do
   73   (fd :: FormData a) <- getFormData fl
   74   runFormWith fd mf fa
   75 
   76 runForm :: Maybe (RequestContext -> FormHtml ()) -> DeformHandler () a -> Handler a
   77 runForm = runFormFiles []
   78 
   79 blankForm :: FormHtml f -> Response
   80 blankForm = okResponse [] . blankFormView
   81 
   82 emailRegex :: Regex.Regex
   83 emailRegex = Regex.makeRegexOpts Regex.compIgnoreCase Regex.blankExecOpt
   84   ("^[-a-z0-9!#$%&'*+/=?^_`{|}~.]*@[a-z0-9][a-z0-9\\.-]*[a-z0-9]\\.[a-z][a-z\\.]*[a-z]$" :: String)
   85 
   86 emailTextForm :: DeformHandler f BS.ByteString
   87 emailTextForm = do
   88   e <- deformCheck "Invalid email address" (Regex.matchTest emailRegex) =<< deform
   89   return $ maybe e (uncurry ((. BSC.map toLower) . (<>)) . flip BS.splitAt e) $ BSC.elemIndex '@' e
   90 
   91 passwordForm :: Account -> DeformHandler f BS.ByteString
   92 passwordForm acct = do
   93   p <- "once" .:> do
   94     p <- deform
   95     deformGuard "Password too short. Must be 7 characters." (7 <= BS.length p)
   96     c <- lift $ focusIO $ passwdCheck p (accountEmail acct) (TE.encodeUtf8 $ partyName $ partyRow $ accountParty acct)
   97     mapM_ (deformError . ("Insecure password: " <>) . TE.decodeLatin1) c
   98     return p
   99   "again" .:> do
  100     a <- deform
  101     deformGuard "Passwords do not match." (a == p)
  102   pw <- liftIO $ BCrypt.hashPasswordUsingPolicy passwordPolicy p
  103   deformMaybe' "Error processing password." pw
  104 
  105 paginateForm :: DeformHandler f Paginate
  106 paginateForm = Paginate
  107   <$> get "offset" paginateOffset
  108   <*> get "limit" paginateLimit
  109   where get t f = t .:> (deformCheck ("invalid " <> t) (\i -> i >= f minBound && i <= f maxBound) =<< deform) <|> return (f def)
  110 
  111 csrfForm :: DeformHandler f ()
  112 csrfForm = do
  113   r <- lift checkVerfHeader
  114   unless r $ do
  115     verf <- lift $ peeks identityVerf
  116     "csverf" .:> maybe
  117       (deformError "You must be logged in to perform this request.")
  118       (\v -> deformGuard "Invalid form verifier. Please logout, reload, and try again." . (v ==) =<< deform)
  119       verf