Better parseTime

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
 <input id="#{theId}" name="#{name}" *{attrs} :isReq:required="" value="#{showVal val}">
@@ -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 :: Text -> Either FormMessage TimeOfDay
-parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0')
+parseTime = either (Left . fromMaybe MsgInvalidTimeFormat . readMay . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser
-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
 
-parseTimeHelper :: (Char, Char, Char, Char, Char, Char)
+timeParser :: Parser TimeOfDay
-                -> Either FormMessage TimeOfDay
+timeParser = do
-parseTimeHelper (h1, h2, m1, m2, s1, s2)
+    skipSpace
-    | h < 0 || h > 23 = Left $ MsgInvalidHour $ pack [h1, h2]
+    h <- hour
-    | m < 0 || m > 59 = Left $ MsgInvalidMinute $ pack [m1, m2]
+    _ <- char ':'
-    | s < 0 || s > 59 = Left $ MsgInvalidSecond $ pack [s1, s2]
+    m <- minsec MsgInvalidMinute
-    | otherwise = Right $ TimeOfDay h m s
+    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?
+    hour = do
-    m = read [m1, m2]
+        x <- digit
-    s = fromInteger $ read [s1, s2]
+        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

yesod-form/Yesod/Form/Types.hs

@@ -151,3 +151,4 @@ data FormMessage = MsgInvalidInteger Text
                  | MsgBoolYes
                  | MsgBoolNo
                  | MsgDelete
+    deriving (Show, Eq, Read)

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)
+        ]

yesod-form/yesod-form.cabal

@@ -7,7 +7,7 @@ maintainer:      Michael Snoyman <michael@snoyman.com>
 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