1 {-# LANGUAGE GeneralizedNewtypeDeriving, DataKinds, DeriveDataTypeable #-}
    2 module Databrary.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 Databrary.JSON as 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