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