yesod/Yesod/Form/Profiles.hs

{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Yesod.Form.Profiles
    ( stringFieldProfile
    , textareaFieldProfile
    , hiddenFieldProfile
    , intFieldProfile
    , dayFieldProfile
    , timeFieldProfile
    , htmlFieldProfile
    , emailFieldProfile
    , urlFieldProfile
    , doubleFieldProfile
    , fileFieldProfile
    , parseDate
    , parseTime
    , Textarea (..)
    ) where

import Yesod.Form.Core
import Yesod.Widget
import Yesod.Request
import Text.Hamlet
import Data.Time (Day, TimeOfDay(..))
import qualified Data.ByteString.Lazy.UTF8 as U
import qualified Text.Email.Validate as Email
import Network.URI (parseURI)
import Database.Persist (PersistField)

import Text.Blaze.Builder.Utf8 (writeChar)
import Text.Blaze.Builder.Core (writeList, writeByteString)

intFieldProfile :: Integral i => FieldProfile sub y i
intFieldProfile = FieldProfile
    { fpParse = maybe (Left "Invalid integer") Right . readMayI
    , fpRender = showI
    , fpWidget = \theId name val isReq -> addBody [$hamlet|
%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$
|]
    }
  where
    showI x = show (fromIntegral x :: Integer)
    readMayI s = case reads s of
                    (x, _):_ -> Just $ fromInteger x
                    [] -> Nothing

doubleFieldProfile :: FieldProfile sub y Double
doubleFieldProfile = FieldProfile
    { fpParse = maybe (Left "Invalid number") Right . readMay
    , fpRender = show
    , fpWidget = \theId name val isReq -> addBody [$hamlet|
%input#$theId$!name=$name$!type=number!:isReq:required!value=$val$
|]
    }

fileFieldProfile :: FieldProfile s m FileInfo
fileFieldProfile = undefined -- FIXME

dayFieldProfile :: FieldProfile sub y Day
dayFieldProfile = FieldProfile
    { fpParse = parseDate
    , fpRender = show
    , fpWidget = \theId name val isReq -> addBody [$hamlet|
%input#$theId$!name=$name$!type=date!:isReq:required!value=$val$
|]
    }

timeFieldProfile :: FieldProfile sub y TimeOfDay
timeFieldProfile = FieldProfile
    { fpParse = parseTime
    , fpRender = show
    , fpWidget = \theId name val isReq -> addBody [$hamlet|
%input#$theId$!name=$name$!:isReq:required!value=$val$
|]
    }

htmlFieldProfile :: FieldProfile sub y Html
htmlFieldProfile = FieldProfile
    { fpParse = Right . preEscapedString
    , fpRender = U.toString . renderHtml
    , fpWidget = \theId name val _isReq -> addBody [$hamlet|
%textarea.html#$theId$!name=$name$ $val$
|]
    }

-- | A newtype wrapper around a 'String' that converts newlines to HTML
-- br-tags.
newtype Textarea = Textarea { unTextarea :: String }
    deriving (Show, Read, Eq, PersistField)
instance ToHtml Textarea where
    toHtml =
        Html . writeList writeHtmlEscapedChar . unTextarea
      where
        -- Taken from blaze-builder and modified with newline handling.
        writeHtmlEscapedChar '<'  = writeByteString "&lt;"
        writeHtmlEscapedChar '>'  = writeByteString "&gt;"
        writeHtmlEscapedChar '&'  = writeByteString "&amp;"
        writeHtmlEscapedChar '"'  = writeByteString "&quot;"
        writeHtmlEscapedChar '\'' = writeByteString "&apos;"
        writeHtmlEscapedChar '\n' = writeByteString "<br>"
        writeHtmlEscapedChar c    = writeChar c

textareaFieldProfile :: FieldProfile sub y Textarea
textareaFieldProfile = FieldProfile
    { fpParse = Right . Textarea
    , fpRender = unTextarea
    , fpWidget = \theId name val _isReq -> addBody [$hamlet|
%textarea#$theId$!name=$name$ $val$
|]
    }

hiddenFieldProfile :: FieldProfile sub y String
hiddenFieldProfile = FieldProfile
    { fpParse = Right
    , fpRender = id
    , fpWidget = \theId name val _isReq -> addBody [$hamlet|
%input!type=hidden#$theId$!name=$name$!value=$val$
|]
    }

stringFieldProfile :: FieldProfile sub y String
stringFieldProfile = FieldProfile
    { fpParse = Right
    , fpRender = id
    , fpWidget = \theId name val isReq -> addBody [$hamlet|
%input#$theId$!name=$name$!type=text!:isReq:required!value=$val$
|]
    }

readMay :: Read a => String -> Maybe a
readMay s = case reads s of
                (x, _):_ -> Just x
                [] -> Nothing

parseDate :: String -> Either String Day
parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right
              . readMay . replace '/' '-'

-- | Replaces all instances of a value in a list by another value.
-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace
replace :: Eq a => a -> a -> [a] -> [a]
replace x y = map (\z -> if z == x then y else z)

parseTime :: String -> Either String TimeOfDay
parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0')
parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')
parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) =
    parseTimeHelper (h1, h2, m1, m2, '0', '0')
parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) =
    let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12
    in parseTimeHelper (h1', h2', m1, m2, '0', '0')
parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =
    parseTimeHelper (h1, h2, m1, m2, s1, s2)
parseTime _ = Left "Invalid time, must be in HH:MM[:SS] format"

parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
                -> Either [Char] TimeOfDay
parseTimeHelper (h1, h2, m1, m2, s1, s2)
    | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h
    | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m
    | s < 0 || s > 59 = Left $ "Invalid second: " ++ show s
    | otherwise = Right $ TimeOfDay h m s
  where
    h = read [h1, h2]
    m = read [m1, m2]
    s = fromInteger $ read [s1, s2]

emailFieldProfile :: FieldProfile s y String
emailFieldProfile = FieldProfile
    { fpParse = \s -> if Email.isValid s
                        then Right s
                        else Left "Invalid e-mail address"
    , fpRender = id
    , fpWidget = \theId name val isReq -> addBody [$hamlet|
%input#$theId$!name=$name$!type=email!:isReq:required!value=$val$
|]
    }

urlFieldProfile :: FieldProfile s y String
urlFieldProfile = FieldProfile
    { fpParse = \s -> case parseURI s of
                        Nothing -> Left "Invalid URL"
                        Just _ -> Right s
    , fpRender = id
    , fpWidget = \theId name val isReq -> addBody [$hamlet|
%input#$theId$!name=$name$!type=url!:isReq:required!value=$val$
|]
    }