Skip to content

Instantly share code, notes, and snippets.

@lukehoersten
Last active December 30, 2015 22:49
Show Gist options
  • Save lukehoersten/7896241 to your computer and use it in GitHub Desktop.
Save lukehoersten/7896241 to your computer and use it in GitHub Desktop.
{-# LANGUAGE OverloadedStrings #-}
module Racemetric.Form.Datetime where
import Control.Applicative ((<$>), (<*>))
import Control.Monad (liftM2, liftM3)
import Data.Text (Text)
import Data.Time.Calendar (Day (..))
import Data.Time.Format (formatTime, parseTime)
import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..),
TimeZone (..), ZonedTime (..))
import System.Locale (defaultTimeLocale)
import Text.Digestive (Form, Result (..), string, validate,
(.:))
import Text.Digestive.Util (readMaybe)
optional :: (String -> Result v a) -> String -> Result v (Maybe a)
optional _ "" = Success Nothing
optional f x  = Just <$> f x
datetimeForm :: Monad m => Maybe ZonedTime -> Form Text m ZonedTime
datetimeForm zonedTime = ZonedTime
<$> localtimeForm (zonedTimeToLocalTime <$> zonedTime)
<*> "timezone" .: timezoneForm (zonedTimeZone <$> zonedTime)
optionalDatetimeForm :: Monad m => Maybe ZonedTime -> Form Text m (Maybe ZonedTime)
optionalDatetimeForm zonedTime = liftM2 ZonedTime
<$> (optionalLocaltimeForm $ zonedTimeToLocalTime <$> zonedTime)
<*> "timezone" .: (optionalTimezoneForm $ zonedTimeZone <$> zonedTime)
localtimeForm :: Monad m => Maybe LocalTime -> Form Text m LocalTime
localtimeForm localTime = LocalTime
<$> "date" .: validate validateDay (string $ show . localDay <$> localTime)
<*> "time" .: validate validateTimeOfDay (string $ formatTime defaultTimeLocale timeFormat . localTimeOfDay <$> localTime)
optionalLocaltimeForm :: Monad m => Maybe LocalTime -> Form Text m (Maybe LocalTime)
optionalLocaltimeForm localTime = liftM2 LocalTime
<$> "date" .: validate (optional validateDay) (string $ show . localDay <$> localTime)
<*> "time" .: validate (optional validateTimeOfDay) (string $ formatTime defaultTimeLocale timeFormat . localTimeOfDay <$> localTime)
timezoneForm :: Monad m => Maybe TimeZone -> Form Text m TimeZone
timezoneForm timeZone = TimeZone
<$> "offset-minutes" .: validate validateTimeZoneOffsetMinutes (string $ show . timeZoneMinutes <$> timeZone)
<*> "is-summer" .: validate validateTimeZoneIsSummer (string $ show . timeZoneSummerOnly <$> timeZone)
<*> "name" .: validate validateTimeZoneName (string $ timeZoneName <$> timeZone)
optionalTimezoneForm :: Monad m => Maybe TimeZone -> Form Text m (Maybe TimeZone)
optionalTimezoneForm timeZone = liftM3 TimeZone
<$> "offset-minutes" .: validate (optional validateTimeZoneOffsetMinutes) (string $ show . timeZoneMinutes <$> timeZone)
<*> "is-summer" .: validate (optional validateTimeZoneIsSummer) (string $ show . timeZoneSummerOnly <$> timeZone)
<*> "name" .: validate (optional validateTimeZoneName) (string $ timeZoneName <$> timeZone)
-- Validators
validateTimeZoneOffsetMinutes :: String -> Result Text Int
validateTimeZoneOffsetMinutes x
| 3 <= length x && length x <= 4 = df $ readMaybe x
| otherwise = Error msg
where df (Just d) | (-720) <= d && d <= 840 = Success d
df _ = Error msg
msg = "Timezone must be offset minutes from UTC."
validateTimeZoneIsSummer :: String -> Result Text Bool
validateTimeZoneIsSummer "true" = Success True
validateTimeZoneIsSummer "false" = Success False
validateTimeZoneIsSummer _ = Error "Timezone daylight savings must be specificed."
validateTimeZoneName :: String -> Result Text String
validateTimeZoneName x
| 0 < length x && length x < 40 = Success x
| otherwise = Error "Timezone name must be specified."
validateDay :: String -> Result Text Day
validateDay x | length x == l = fm $ readMaybe x
| otherwise = Error "Date must be of the form YYYY-MM-DD."
where l = length ("yyyy-mm-dd" :: String)
fm (Just d) = Success d
fm Nothing = Error "Date must be of the form YYYY-MM-DD."
validateTimeOfDay :: String -> Result Text TimeOfDay
validateTimeOfDay x
| length x == l = fs $ parseTime defaultTimeLocale timeFormat x -- TODO Read maybe
| otherwise = Error "Time must be of form hh:mm pp."
where l = length ("hh:mm pp" :: String)
fs (Just t) = Success t
fs Nothing = Error "Time must be of form hh:mm pp."
timeFormat :: String
timeFormat = "%I:%M %p" -- HH:MM PP
@lukehoersten
Copy link
Author

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment