diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index 81bb67b5..1d051dbc 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -67,7 +67,7 @@ import Database.Persist (PersistField) import Database.Persist.Store (Entity (..)) import Text.HTML.SanitizeXSS (sanitizeBalance) import Control.Monad (when, unless) -import Data.Maybe (listToMaybe) +import Data.Maybe (listToMaybe, fromMaybe) import qualified Blaze.ByteString.Builder.Html.Utf8 as B import Blaze.ByteString.Builder (writeByteString, toLazyByteString) @@ -92,7 +92,9 @@ import Yesod.Core (toPathPiece, GHandler, PathPiece, fromPathPiece) import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery) import Control.Arrow ((&&&)) -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<|>)) + +import Data.Attoparsec.Text defaultFormMessage :: FormMessage -> Text defaultFormMessage = englishFormMessage @@ -145,7 +147,7 @@ $newline never timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay timeField = Field - { fieldParse = blank $ parseTime . unpack + { fieldParse = blank parseTime , fieldView = \theId name attrs val isReq -> toWidget [hamlet| $newline never @@ -239,29 +241,51 @@ parseDate = maybe (Left MsgInvalidDay) Right replace :: Eq a => a -> a -> [a] -> [a] replace x y = map (\z -> if z == x then y else z) -parseTime :: String -> Either FormMessage 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 MsgInvalidTimeFormat +parseTime :: Text -> Either FormMessage TimeOfDay +parseTime = either (Left . fromMaybe MsgInvalidTimeFormat . readMay . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser -parseTimeHelper :: (Char, Char, Char, Char, Char, Char) - -> Either FormMessage TimeOfDay -parseTimeHelper (h1, h2, m1, m2, s1, s2) - | h < 0 || h > 23 = Left $ MsgInvalidHour $ pack [h1, h2] - | m < 0 || m > 59 = Left $ MsgInvalidMinute $ pack [m1, m2] - | s < 0 || s > 59 = Left $ MsgInvalidSecond $ pack [s1, s2] - | otherwise = Right $ TimeOfDay h m s +timeParser :: Parser TimeOfDay +timeParser = do + skipSpace + h <- hour + _ <- char ':' + m <- minsec MsgInvalidMinute + hasSec <- (char ':' >> return True) <|> return False + s <- if hasSec then minsec MsgInvalidSecond else return 0 + skipSpace + isPM <- + (string "am" >> return (Just False)) <|> + (string "AM" >> return (Just False)) <|> + (string "pm" >> return (Just True)) <|> + (string "PM" >> return (Just True)) <|> + return Nothing + h' <- + case isPM of + Nothing -> return h + Just x + | h <= 0 || h > 12 -> fail $ show $ MsgInvalidHour $ pack $ show h + | h == 12 -> return $ if x then 12 else 0 + | otherwise -> return $ h + (if x then 12 else 0) + skipSpace + endOfInput + return $ TimeOfDay h' m s where - h = read [h1, h2] -- FIXME isn't this a really bad idea? - m = read [m1, m2] - s = fromInteger $ read [s1, s2] + hour = do + x <- digit + y <- (return <$> digit) <|> return [] + let xy = x : y + let i = read xy + if i < 0 || i >= 24 + then fail $ show $ MsgInvalidHour $ pack xy + else return i + minsec msg = do + x <- digit + y <- digit <|> fail (show $ msg $ pack [x]) + let xy = [x, y] + let i = read xy + if i < 0 || i >= 60 + then fail $ show $ msg $ pack xy + else return i emailField :: RenderMessage master FormMessage => Field sub master Text emailField = Field diff --git a/yesod-form/Yesod/Form/Types.hs b/yesod-form/Yesod/Form/Types.hs index 8cd47115..d444166b 100644 --- a/yesod-form/Yesod/Form/Types.hs +++ b/yesod-form/Yesod/Form/Types.hs @@ -151,3 +151,4 @@ data FormMessage = MsgInvalidInteger Text | MsgBoolYes | MsgBoolNo | MsgDelete + deriving (Show, Eq, Read) diff --git a/yesod-form/test/main.hs b/yesod-form/test/main.hs new file mode 100644 index 00000000..5cbde19f --- /dev/null +++ b/yesod-form/test/main.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} +import Test.HUnit +import Test.Hspec.Monadic +import Test.Hspec.HUnit () +import Data.Time (TimeOfDay (TimeOfDay)) +import Data.Text (pack) + +import Yesod.Form.Fields (parseTime) +import Yesod.Form.Types + +main :: IO () +main = hspec $ + describe "parseTime" $ mapM_ (\(s, e) -> it s $ parseTime (pack s) @?= e) + [ ("01:00:00", Right $ TimeOfDay 1 0 0) + , ("1:00", Right $ TimeOfDay 1 0 0) + , ("1:00 AM", Right $ TimeOfDay 1 0 0) + , ("1:00 am", Right $ TimeOfDay 1 0 0) + , ("1:00AM", Right $ TimeOfDay 1 0 0) + , ("1:00am", Right $ TimeOfDay 1 0 0) + , ("01:00:00am", Right $ TimeOfDay 1 0 0) + , ("01:00:00 am", Right $ TimeOfDay 1 0 0) + , ("01:00:00AM", Right $ TimeOfDay 1 0 0) + , ("01:00:00 AM", Right $ TimeOfDay 1 0 0) + , ("1:00:01", Right $ TimeOfDay 1 0 1) + , ("1:00:02 AM", Right $ TimeOfDay 1 0 2) + , ("1:00:04 am", Right $ TimeOfDay 1 0 4) + , ("1:00:64 am", Left $ MsgInvalidSecond "64") + , ("1:00:4 am", Left $ MsgInvalidSecond "4") + , ("0:00", Right $ TimeOfDay 0 0 0) + , ("12:00am", Right $ TimeOfDay 0 0 0) + , ("12:00pm", Right $ TimeOfDay 12 0 0) + , ("12:7pm", Left $ MsgInvalidMinute "7") + , ("23:47", Right $ TimeOfDay 23 47 0) + ] diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index bed5bd56..4733da89 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -7,7 +7,7 @@ maintainer: Michael Snoyman synopsis: Form handling support for Yesod Web Framework category: Web, Yesod stability: Stable -cabal-version: >= 1.6 +cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/ description: Form handling support for Yesod Web Framework @@ -34,6 +34,7 @@ library , containers >= 0.2 , blaze-html >= 0.5 && < 0.6 , blaze-markup >= 0.5.1 && < 0.6 + , attoparsec >= 0.10 && < 0.11 exposed-modules: Yesod.Form Yesod.Form.Class @@ -54,6 +55,17 @@ library -- FIXME Yesod.Helpers.Crud ghc-options: -Wall +test-suite test + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: test + build-depends: base + , yesod-form + , time + , hspec + , HUnit + , text + source-repository head type: git location: https://github.com/yesodweb/yesod