module Controller.Form
( FormData
, DeformHandler
, runFormFiles
, runForm
, blankForm
, emailTextForm
, passwordForm
, paginateForm
, csrfForm
) where
import Control.Applicative ((<|>))
import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask)
import Control.Monad.Trans.Class (lift)
import qualified Crypto.BCrypt as BCrypt
import qualified Data.Aeson as JSON
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.Char (toLower)
import Data.Monoid ((<>))
import qualified Data.Text.Encoding as TE
import Data.Word (Word64)
import Network.HTTP.Types (badRequest400)
import qualified Text.Blaze.Html5 as Html
import qualified Text.Regex.Posix as Regex
import Has
import Model.Paginate
import Model.Party
import Model.Identity
import Service.Passwd
import HTTP.Parse (FileContent)
import HTTP.Form (FormData)
import HTTP.Form.Deform
import HTTP.Form.View (runFormView, blankFormView)
import HTTP.Form.Errors (FormErrors)
import Action.Response
import Action.Types
import Action.Form (getFormData)
import Controller.Permission (checkVerfHeader)
import View.Form (FormHtml)
type DeformHandler f a = DeformT f Handler a
jsonFormErrors :: FormErrors -> Response
jsonFormErrors = response badRequest400 [] . JSON.toEncoding
htmlFormErrors :: (FormErrors -> Html.Html) -> FormErrors -> Response
htmlFormErrors f = response badRequest400 [] . f
handleForm :: (FormErrors -> Response) -> Either FormErrors a -> Handler a
handleForm re = either (result . re) return
handleFormErrors :: Maybe (FormErrors -> Html.Html) -> Either FormErrors a -> Handler a
handleFormErrors = handleForm . maybe jsonFormErrors htmlFormErrors
runFormWith :: FormData f -> Maybe (RequestContext -> FormHtml f) -> DeformHandler f a -> Handler a
runFormWith fd mf fa = do
req <- ask
let fv hv = runFormView (hv req) fd
handleFormErrors (fv <$> mf) =<< runDeform fa fd
runFormFiles
:: FileContent f => [(BS.ByteString, Word64)] -> Maybe (RequestContext -> FormHtml f) -> DeformHandler f a -> Handler a
runFormFiles fl mf fa = do
(fd :: FormData a) <- getFormData fl
runFormWith fd mf fa
runForm :: Maybe (RequestContext -> FormHtml ()) -> DeformHandler () a -> Handler a
runForm = runFormFiles []
blankForm :: FormHtml f -> Response
blankForm = okResponse [] . blankFormView
emailRegex :: Regex.Regex
emailRegex = Regex.makeRegexOpts Regex.compIgnoreCase Regex.blankExecOpt
("^[-a-z0-9!#$%&'*+/=?^_`{|}~.]*@[a-z0-9][a-z0-9\\.-]*[a-z0-9]\\.[a-z][a-z\\.]*[a-z]$" :: String)
emailTextForm :: DeformHandler f BS.ByteString
emailTextForm = do
e <- deformCheck "Invalid email address" (Regex.matchTest emailRegex) =<< deform
return $ maybe e (uncurry ((. BSC.map toLower) . (<>)) . flip BS.splitAt e) $ BSC.elemIndex '@' e
data UpdatePasswordRequest = UpdatePasswordRequest BSC.ByteString BSC.ByteString
passwordForm :: Account -> DeformHandler f BS.ByteString
passwordForm acct = do
p <- "once" .:> do
p <- deform
deformGuard "Password too short. Must be 7 characters." (7 <= BS.length p)
c <- lift $ focusIO $ passwdCheck p (accountEmail acct) (TE.encodeUtf8 $ partyName $ partyRow $ accountParty acct)
mapM_ (deformError . ("Insecure password: " <>) . TE.decodeLatin1) c
return p
"again" .:> do
a <- deform
let _ = UpdatePasswordRequest p a
deformGuard "Passwords do not match." (a == p)
pw <- liftIO $ BCrypt.hashPasswordUsingPolicy passwordPolicy p
deformMaybe' "Error processing password." pw
paginateForm :: DeformHandler f Paginate
paginateForm = Paginate
<$> get "offset" paginateOffset
<*> get "limit" paginateLimit
where get t f = t .:> (deformCheck ("invalid " <> t) (\i -> i >= f minBound && i <= f maxBound) =<< deform) <|> return (f def)
csrfForm :: DeformHandler f ()
csrfForm = do
r <- lift checkVerfHeader
unless r $ do
verf <- lift $ peeks identityVerf
"csverf" .:> maybe
(deformError "You must be logged in to perform this request.")
(\v -> deformGuard "Invalid form verifier. Please logout, reload, and try again." . (v ==) =<< deform)
verf