module Handler.ComposeFields (
addressField
, parseAddress
, parseAddresses
, showAddress
, headerField
, multiFile
) where
import Import
import StaticFiles
import Data.Attoparsec.Text
import Data.String (fromString)
import Network.Mail.Mime (Address(..))
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Text.Email.Validate as E
emailInBrackets :: Parser T.Text
emailInBrackets = do
void $ char '<'
y <- takeTill (=='>') <?> "Email address"
void (char '>' <?> "Expecting '>'")
skipSpace
return y
quotedName :: Parser T.Text
quotedName = do
void $ char '"'
x <- takeTill (=='"')
void $ char '"'
skipSpace
let parts = T.split (==',') x
return $ case parts of
(p:ps) -> T.unwords $ map T.strip $ ps ++ [p]
[] -> ""
unquotedName :: Parser T.Text
unquotedName = T.strip <$> takeTill (\x -> x == '<' || x == ',')
address :: Parser Address
address = do
skipSpace
x <- quotedName <|> unquotedName
y <- Just <$> emailInBrackets <|> return Nothing
case y of
Just e -> return $ Address (Just x) e
Nothing -> return $ Address Nothing x
addresses :: Parser [Address]
addresses = do as <- address `sepBy1` char ','
endOfInput <?> "Expecting ',' or '>'"
return as
checkAddr :: Address -> Either (SomeMessage App) Address
checkAddr a@(Address _ e) | E.isValid (T.encodeUtf8 e) = Right a
checkAddr (Address _ e) = Left $ SomeMessage $ MsgInvalidEmail e
parseAddress :: T.Text -> Either (SomeMessage App) Address
parseAddress t = case parseOnly' address t of
Left err -> Left $ fromString $ concat ["Error parsing ", T.unpack t, ": ", err]
Right a -> checkAddr a
parseAddresses :: T.Text -> Either (SomeMessage App) [Address]
parseAddresses t = case parseOnly' addresses t of
Left err -> Left $ fromString $ concat ["Error parsing ", T.unpack t, ": ", err]
Right [(Address Nothing "")] -> Right []
Right a -> mapM checkAddr a
showAddress :: Address -> T.Text
showAddress (Address {addressName = Just name, addressEmail = e}) = T.concat [name, " <", e, ">"]
showAddress (Address {addressName = Nothing, addressEmail = e}) = e
addrWidget :: FieldViewFunc (HandlerT App IO) [Address]
addrWidget theID name attrs val isReq = do
addStylesheet $ StaticR css_select2_css
addScript $ StaticR js_select2_3_4_1_min_js
let addrs = either id (T.intercalate "," . map showAddress) val
[whamlet|
<input type=text ##{theID} name=#{name} .addressfield :isReq:required value="#{addrs}" *{attrs}>
|]
addressField :: Field (HandlerT App IO) [Address]
addressField = Field
{ fieldParse = \addr _ -> case addr of
[] -> return $ Right Nothing
(a:_) -> return $ Just <$> parseAddresses a
, fieldView = addrWidget
, fieldEnctype = UrlEncoded
}
header :: Parser (B.ByteString, T.Text)
header = do
k <- takeWhile1 (\c -> not (isEndOfLine c) && c /= ':')
void $ char ':'
skipSpace
v <- takeTill isEndOfLine
return (T.encodeUtf8 k, v)
headers :: Parser [(B.ByteString, T.Text)]
headers = sepBy header endOfLine <?> "Headers"
headerField :: Field (HandlerT App IO) [(B.ByteString,T.Text)]
headerField = Field
{ fieldParse = \x _ -> case x of
[] -> return $ Right Nothing
("":_) -> return $ Right Nothing
(n:_) -> return $ case parseOnly' headers n of
Left err -> Left $ fromString err
Right [] -> Right $ Nothing
Right h -> Right $ Just h
, fieldView = \theId name attrs val isReq -> do
let hdrs = case val of
Left txt -> txt
Right vals -> T.intercalate "\n" [ T.decodeUtf8 x <> ": " <> y | (x,y) <- vals]
[whamlet|
<textarea id=#{theId} name=#{name} *{attrs} rows=4 cols=50 wrap=off :isReq:required>
#{hdrs}
|]
, fieldEnctype = UrlEncoded
}
multiFile :: Field (HandlerT master IO) [FileInfo]
multiFile = Field p view Multipart
where
p _ fs = return $ Right $ Just fs
view fId name attrs _ _ = [whamlet|
<input type=file name=#{name} ##{fId} multiple *{attrs}>
|]
parseOnly' :: Parser a -> T.Text -> Either String a
parseOnly' p t = checkRes (parse p t)
where checkRes result = case result of
Fail _ ctx err -> Left $ show ctx ++ " " ++ err
Partial f -> checkRes $ f ""
Done _ x -> Right x