Datetime.hs

{-# 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

Doug's: https://gist.github.com/mightybyte/7896191