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