1 {-# LANGUAGE GeneralizedNewtypeDeriving, DataKinds, DeriveDataTypeable #-} 2 module Model.Offset 3 ( Offset(..) 4 , offsetMillis 5 , diffTimeOffset 6 , offsetDiffTime 7 ) where 8 9 import Data.Char (isDigit, digitToInt) 10 import Data.Fixed (Fixed(..), HasResolution(..), Milli, Pico) 11 import qualified Data.Scientific as Sci 12 import qualified Data.Text as T 13 import Data.Time (DiffTime) 14 import Data.Typeable (Typeable) 15 import Database.PostgreSQL.Typed.Types (PGParameter(..), PGColumn(..)) 16 import Numeric (showSigned, showFFloat, readSigned, readDec) 17 import qualified Text.ParserCombinators.ReadP as RP 18 import qualified Text.ParserCombinators.ReadPrec as RP (lift) 19 import Text.Read (readMaybe, Read(readPrec)) 20 import qualified Web.Route.Invertible as R 21 22 import qualified JSON 23 24 newtype Offset = Offset { offsetMilli :: Milli } deriving (Eq, Ord, Num, Real, Fractional, RealFrac, Typeable) 25 26 fixedToFixed :: (HasResolution a, HasResolution b) => Fixed a -> Fixed b 27 fixedToFixed x@(MkFixed xv) = y where 28 yv = xv * yr `div` xr 29 y = MkFixed yv 30 xr = resolution x 31 yr = resolution y 32 33 -- DiffTime is really Pico and has specialized realToFrac 34 diffTimeOffset :: DiffTime -> Offset 35 diffTimeOffset = Offset . fixedToFixed . (realToFrac :: DiffTime -> Pico) 36 37 offsetDiffTime :: Offset -> DiffTime 38 offsetDiffTime = (realToFrac :: Pico -> DiffTime) . fixedToFixed . offsetMilli 39 40 -- | Get the underlying fixed integer, before scaling to the appropriate decimal 41 offsetMillis :: Offset -> Integer 42 offsetMillis (Offset (MkFixed t)) = t 43 44 instance PGParameter "interval" Offset where 45 pgEncode t = pgEncode t . offsetDiffTime 46 pgEncodeValue e t = pgEncodeValue e t . offsetDiffTime 47 pgLiteral t = pgLiteral t . offsetDiffTime 48 instance PGColumn "interval" Offset where 49 pgDecode t = diffTimeOffset . pgDecode t 50 pgDecodeValue e t = diffTimeOffset . pgDecodeValue e t 51 52 -- | Display Offset using colon delimited time format 53 instance Show Offset where 54 -- showsPrec p = showsPrec p . offsetMillis 55 showsPrec p (Offset t) = showSigned ss p t where 56 ss a = 57 (if h /= 0 then shows (h :: Integer) . (':' :) else id) 58 . pads m' . shows m' . (':' :) 59 . pads s' . showFFloat Nothing (fromIntegral s' + realToFrac f :: Double) 60 where 61 (s, f) = properFraction a 62 (m, s') = divMod s 60 63 (h, m') = divMod m 60 64 pads x 65 | x < 10 = ('0' :) 66 | otherwise = id 67 68 -- | Read Offset from a colon delimited time string 69 instance Read Offset where 70 readPrec = RP.lift $ rm RP.<++ rc where 71 -- parse milliseconds: 72 rm = do 73 m <- RP.readS_to_P (readSigned readDec) 74 r <- RP.look 75 case r of 76 (':':_) -> RP.pfail 77 ('.':_) -> RP.pfail 78 _ -> return $ Offset (MkFixed m) 79 -- parse seconds with colons: 80 rc = do 81 pm <- RP.option '+' $ RP.satisfy (`elem` "-+") 82 c <- RP.sepBy1 (RP.readS_to_P readDec) (RP.char ':') 83 ms <- RP.option 0 (do 84 _ <- RP.char '.' 85 foldr (\d m -> 100*digitToInt d + m `div` 10) 0 <$> RP.many (RP.satisfy isDigit)) 86 Offset . MkFixed . (if pm == '-' then negate else id) . (toInteger ms +) . (1000 *) <$> case c of 87 [s] -> return s 88 [m, s] -> return (60*m + s) 89 [h, m, s] -> return (60*(60*h + m) + s) 90 [d, h, m, s] -> return (60*(60*(24*d + h) + m) + s) 91 _ -> RP.pfail 92 93 -- | Format offset value for inclusion in a JSON object. Use the millisecond integer representation 94 instance JSON.ToJSON Offset where 95 toJSON = JSON.Number . fromInteger . offsetMillis 96 97 -- | Extract from JSON value. Accept integer milliseconds, time colon formatted string, or false (0) 98 instance JSON.FromJSON Offset where 99 parseJSON (JSON.Number ms) | Sci.base10Exponent ms < 10 = return $ Offset $ MkFixed $ floor ms 100 parseJSON (JSON.String s) = maybe (fail "Invalid offset string") return $ readMaybe $ T.unpack s 101 parseJSON (JSON.Bool False) = return 0 102 parseJSON _ = fail "Invalid offset" 103 104 instance R.Parameter T.Text Offset where 105 renderParameter = T.pack . show . offsetMillis 106