{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.UnixTime.Conv (
    formatUnixTime,
    formatUnixTimeGMT,
    parseUnixTime,
    parseUnixTimeGMT,
    webDateFormat,
    mailDateFormat,
    fromEpochTime,
    toEpochTime,
    fromClockTime,
    toClockTime,
) where

import Control.Applicative
import Data.ByteString.Char8
import Data.ByteString.Unsafe
import Data.UnixTime.Types
import Foreign.C.String
import Foreign.C.Types
import Foreign.Marshal.Alloc
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Types (EpochTime)
import System.Time (ClockTime (..))

-- $setup
-- >>> import Data.Function (on)
-- >>> :set -XOverloadedStrings

foreign import ccall unsafe "c_parse_unix_time"
    c_parse_unix_time :: CString -> CString -> IO CTime

foreign import ccall unsafe "c_parse_unix_time_gmt"
    c_parse_unix_time_gmt :: CString -> CString -> IO CTime

foreign import ccall unsafe "c_format_unix_time"
    c_format_unix_time :: CString -> CTime -> CString -> CInt -> IO CSize

foreign import ccall unsafe "c_format_unix_time_gmt"
    c_format_unix_time_gmt :: CString -> CTime -> CString -> CInt -> IO CSize

----------------------------------------------------------------

-- |
-- Parsing 'ByteString' to 'UnixTime' interpreting as localtime.
-- This is a wrapper for strptime_l().
-- Many implementations of strptime_l() do not support %Z and
-- some implementations of strptime_l() do not support %z, either.
-- 'utMicroSeconds' is always set to 0.
parseUnixTime :: Format -> ByteString -> UnixTime
parseUnixTime :: Format -> Format -> UnixTime
parseUnixTime Format
fmt Format
str = IO UnixTime -> UnixTime
forall a. IO a -> a
unsafePerformIO (IO UnixTime -> UnixTime) -> IO UnixTime -> UnixTime
forall a b. (a -> b) -> a -> b
$
    Format -> (CString -> IO UnixTime) -> IO UnixTime
forall a. Format -> (CString -> IO a) -> IO a
useAsCString Format
fmt ((CString -> IO UnixTime) -> IO UnixTime)
-> (CString -> IO UnixTime) -> IO UnixTime
forall a b. (a -> b) -> a -> b
$ \CString
cfmt ->
        Format -> (CString -> IO UnixTime) -> IO UnixTime
forall a. Format -> (CString -> IO a) -> IO a
useAsCString Format
str ((CString -> IO UnixTime) -> IO UnixTime)
-> (CString -> IO UnixTime) -> IO UnixTime
forall a b. (a -> b) -> a -> b
$ \CString
cstr -> do
            CTime
sec <- CString -> CString -> IO CTime
c_parse_unix_time CString
cfmt CString
cstr
            UnixTime -> IO UnixTime
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnixTime -> IO UnixTime) -> UnixTime -> IO UnixTime
forall a b. (a -> b) -> a -> b
$ CTime -> Int32 -> UnixTime
UnixTime CTime
sec Int32
0

-- |
-- Parsing 'ByteString' to 'UnixTime' interpreting as GMT.
-- This is a wrapper for strptime_l().
-- 'utMicroSeconds' is always set to 0.
--
-- >>> parseUnixTimeGMT webDateFormat "Thu, 01 Jan 1970 00:00:00 GMT"
-- UnixTime {utSeconds = 0, utMicroSeconds = 0}
parseUnixTimeGMT :: Format -> ByteString -> UnixTime
parseUnixTimeGMT :: Format -> Format -> UnixTime
parseUnixTimeGMT Format
fmt Format
str = IO UnixTime -> UnixTime
forall a. IO a -> a
unsafePerformIO (IO UnixTime -> UnixTime) -> IO UnixTime -> UnixTime
forall a b. (a -> b) -> a -> b
$
    Format -> (CString -> IO UnixTime) -> IO UnixTime
forall a. Format -> (CString -> IO a) -> IO a
useAsCString Format
fmt ((CString -> IO UnixTime) -> IO UnixTime)
-> (CString -> IO UnixTime) -> IO UnixTime
forall a b. (a -> b) -> a -> b
$ \CString
cfmt ->
        Format -> (CString -> IO UnixTime) -> IO UnixTime
forall a. Format -> (CString -> IO a) -> IO a
useAsCString Format
str ((CString -> IO UnixTime) -> IO UnixTime)
-> (CString -> IO UnixTime) -> IO UnixTime
forall a b. (a -> b) -> a -> b
$ \CString
cstr -> do
            CTime
sec <- CString -> CString -> IO CTime
c_parse_unix_time_gmt CString
cfmt CString
cstr
            UnixTime -> IO UnixTime
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnixTime -> IO UnixTime) -> UnixTime -> IO UnixTime
forall a b. (a -> b) -> a -> b
$ CTime -> Int32 -> UnixTime
UnixTime CTime
sec Int32
0

----------------------------------------------------------------

-- |
-- Formatting 'UnixTime' to 'ByteString' in local time.
-- This is a wrapper for strftime_l().
-- 'utMicroSeconds' is ignored.
-- The result depends on the TZ environment variable.
formatUnixTime :: Format -> UnixTime -> IO ByteString
formatUnixTime :: Format -> UnixTime -> IO Format
formatUnixTime Format
fmt UnixTime
t =
    (CString -> CTime -> CString -> CInt -> IO CSize)
-> Format -> UnixTime -> IO Format
formatUnixTimeHelper CString -> CTime -> CString -> CInt -> IO CSize
c_format_unix_time Format
fmt UnixTime
t
{-# INLINE formatUnixTime #-}

-- |
-- Formatting 'UnixTime' to 'ByteString' in GMT.
-- This is a wrapper for strftime_l().
-- 'utMicroSeconds' is ignored.
--
-- >>> formatUnixTimeGMT webDateFormat $ UnixTime 0 0
-- "Thu, 01 Jan 1970 00:00:00 GMT"
-- >>> let ut = UnixTime 100 200
-- >>> let str = formatUnixTimeGMT "%s" ut
-- >>> let ut' = parseUnixTimeGMT "%s" str
-- >>> ((==) `on` utSeconds) ut ut'
-- True
-- >>> ((==) `on` utMicroSeconds) ut ut'
-- False
formatUnixTimeGMT :: Format -> UnixTime -> ByteString
formatUnixTimeGMT :: Format -> UnixTime -> Format
formatUnixTimeGMT Format
fmt UnixTime
t =
    IO Format -> Format
forall a. IO a -> a
unsafePerformIO (IO Format -> Format) -> IO Format -> Format
forall a b. (a -> b) -> a -> b
$ (CString -> CTime -> CString -> CInt -> IO CSize)
-> Format -> UnixTime -> IO Format
formatUnixTimeHelper CString -> CTime -> CString -> CInt -> IO CSize
c_format_unix_time_gmt Format
fmt UnixTime
t
{-# INLINE formatUnixTimeGMT #-}

-- |
-- Helper handling memory allocation for formatUnixTime and formatUnixTimeGMT.
formatUnixTimeHelper
    :: (CString -> CTime -> CString -> CInt -> IO CSize)
    -> Format
    -> UnixTime
    -> IO ByteString
formatUnixTimeHelper :: (CString -> CTime -> CString -> CInt -> IO CSize)
-> Format -> UnixTime -> IO Format
formatUnixTimeHelper CString -> CTime -> CString -> CInt -> IO CSize
formatFun Format
fmt (UnixTime CTime
sec Int32
_) =
    Format -> (CString -> IO Format) -> IO Format
forall a. Format -> (CString -> IO a) -> IO a
useAsCString Format
fmt ((CString -> IO Format) -> IO Format)
-> (CString -> IO Format) -> IO Format
forall a b. (a -> b) -> a -> b
$ \CString
cfmt -> do
        let siz :: Int
siz = Int
80
        CString
ptr <- Int -> IO CString
forall a. Int -> IO (Ptr a)
mallocBytes Int
siz
        Int
len <- CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CSize -> Int) -> IO CSize -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> CTime -> CString -> CInt -> IO CSize
formatFun CString
cfmt CTime
sec CString
ptr (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
siz)
        CString
ptr' <- CString -> Int -> IO CString
forall a. Ptr a -> Int -> IO (Ptr a)
reallocBytes CString
ptr (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        CString -> IO Format
unsafePackMallocCString CString
ptr' -- FIXME: Use unsafePackMallocCStringLen from bytestring-0.10.2.0

----------------------------------------------------------------

-- |
-- Format for web (RFC 2616).
-- The value is \"%a, %d %b %Y %H:%M:%S GMT\".
-- This should be used with 'formatUnixTimeGMT' and 'parseUnixTimeGMT'.
webDateFormat :: Format
webDateFormat :: Format
webDateFormat = Format
"%a, %d %b %Y %H:%M:%S GMT"

-- |
-- Format for e-mail (RFC 5322).
-- The value is \"%a, %d %b %Y %H:%M:%S %z\".
-- This should be used with 'formatUnixTime' and 'parseUnixTime'.
mailDateFormat :: Format
mailDateFormat :: Format
mailDateFormat = Format
"%a, %d %b %Y %H:%M:%S %z"

----------------------------------------------------------------

-- |
-- From 'EpochTime' to 'UnixTime' setting 'utMicroSeconds' to 0.
fromEpochTime :: EpochTime -> UnixTime
fromEpochTime :: CTime -> UnixTime
fromEpochTime CTime
sec = CTime -> Int32 -> UnixTime
UnixTime CTime
sec Int32
0

-- |
-- From 'UnixTime' to 'EpochTime' ignoring 'utMicroSeconds'.
toEpochTime :: UnixTime -> EpochTime
toEpochTime :: UnixTime -> CTime
toEpochTime (UnixTime CTime
sec Int32
_) = CTime
sec

-- |
-- From 'ClockTime' to 'UnixTime'.
fromClockTime :: ClockTime -> UnixTime
fromClockTime :: ClockTime -> UnixTime
fromClockTime (TOD Integer
sec Integer
psec) = CTime -> Int32 -> UnixTime
UnixTime CTime
sec' Int32
usec'
  where
    sec' :: CTime
sec' = Integer -> CTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
sec
    usec' :: Int32
usec' = Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int32) -> Integer -> Int32
forall a b. (a -> b) -> a -> b
$ Integer
psec Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1000000

-- |
-- From 'UnixTime' to 'ClockTime'.
toClockTime :: UnixTime -> ClockTime
toClockTime :: UnixTime -> ClockTime
toClockTime (UnixTime CTime
sec Int32
usec) = Integer -> Integer -> ClockTime
TOD Integer
sec' Integer
psec'
  where
    sec' :: Integer
sec' = Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (CTime -> Rational
forall a. Real a => a -> Rational
toRational CTime
sec)
    psec' :: Integer
psec' = Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Integer) -> Int32 -> Integer
forall a b. (a -> b) -> a -> b
$ Int32
usec Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
1000000