Better parseTime
This commit is contained in:
Michael Snoyman
parent
33c39662b9
commit
14f1fd1e27
@ -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 (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
|
||||
|
||||
@ -151,3 +151,4 @@ data FormMessage = MsgInvalidInteger Text
|
||||
| MsgBoolYes
|
||||
| MsgBoolNo
|
||||
| MsgDelete
|
||||
deriving (Show, Eq, Read)
|
||||
|
||||
34
yesod-form/test/main.hs
Normal file
34
yesod-form/test/main.hs
Normal file
@ -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)
|
||||
]
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user