1 {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
    2 module 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 Has
   33 import Model.Paginate
   34 import Model.Party
   35 import Model.Identity
   36 import Service.Passwd
   37 import HTTP.Parse (FileContent)
   38 import HTTP.Form (FormData)
   39 import HTTP.Form.Deform
   40 import HTTP.Form.View (runFormView, blankFormView)
   41 import HTTP.Form.Errors (FormErrors)
   42 import Action.Response
   43 import Action.Types
   44 import Action.Form (getFormData)
   45 import Controller.Permission (checkVerfHeader)
   46 import 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 data UpdatePasswordRequest = UpdatePasswordRequest BSC.ByteString BSC.ByteString
   92 
   93 passwordForm :: Account -> DeformHandler f BS.ByteString
   94 passwordForm acct = do
   95   p <- "once" .:> do
   96     p <- deform
   97     deformGuard "Password too short. Must be 7 characters." (7 <= BS.length p)
   98     c <- lift $ focusIO $ passwdCheck p (accountEmail acct) (TE.encodeUtf8 $ partyName $ partyRow $ accountParty acct)
   99     mapM_ (deformError . ("Insecure password: " <>) . TE.decodeLatin1) c
  100     return p
  101   "again" .:> do
  102     a <- deform
  103     let _ = UpdatePasswordRequest p a
  104     deformGuard "Passwords do not match." (a == p)
  105   pw <- liftIO $ BCrypt.hashPasswordUsingPolicy passwordPolicy p
  106   deformMaybe' "Error processing password." pw
  107 
  108 paginateForm :: DeformHandler f Paginate
  109 paginateForm = Paginate
  110   <$> get "offset" paginateOffset
  111   <*> get "limit" paginateLimit
  112   where get t f = t .:> (deformCheck ("invalid " <> t) (\i -> i >= f minBound && i <= f maxBound) =<< deform) <|> return (f def)
  113 
  114 csrfForm :: DeformHandler f ()
  115 csrfForm = do
  116   r <- lift checkVerfHeader
  117   unless r $ do
  118     verf <- lift $ peeks identityVerf
  119     "csverf" .:> maybe
  120       (deformError "You must be logged in to perform this request.")
  121       (\v -> deformGuard "Invalid form verifier. Please logout, reload, and try again." . (v ==) =<< deform)
  122       verf