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