{-# LANGUAGE ForeignFunctionInterface #-}

{- |
Module      : Time.Internal
License     : BSD-style
Copyright   : (c) 2014 Vincent Hanquez <vincent@snarc.org>
Stability   : experimental
Portability : unknown

This module depends on the operating system. This is the version for Unix-like
operating systems.

Time lowlevel helpers for the unix operating system.

Depend on localtime_r and gmtime_r. Some obscure Unix system might not support
them.
-}

module Time.Internal
  ( dateTimeFromUnixEpochP
  , dateTimeFromUnixEpoch
  , systemGetTimezone
  , systemGetElapsed
  , systemGetElapsedP
  ) where

import           Foreign.C.Types ( CInt, CLong, CTime (..) )
import           Foreign.Marshal.Alloc ( alloca, allocaBytesAligned )
import           Foreign.Ptr ( Ptr, castPtr, nullPtr )
import           Foreign.Storable ( Storable (..) )
import           System.IO.Unsafe ( unsafePerformIO )
import           Time.Types
                   ( Date (..), DateTime (..), Elapsed (..), ElapsedP (..)
                   , NanoSeconds (..), Seconds (..), TimeOfDay (..)
                   , TimezoneOffset (..)
                   )

-- | Convert a Unix epoch precise to t'DateTime'.

dateTimeFromUnixEpochP :: ElapsedP -> DateTime
dateTimeFromUnixEpochP :: ElapsedP -> DateTime
dateTimeFromUnixEpochP (ElapsedP Elapsed
e NanoSeconds
ns) = NanoSeconds -> CTm -> DateTime
fromCP NanoSeconds
ns (CTm -> DateTime) -> CTm -> DateTime
forall a b. (a -> b) -> a -> b
$ Elapsed -> CTm
rawGmTime Elapsed
e

-- | Convert a Unix epoch to t'DateTime'.

dateTimeFromUnixEpoch :: Elapsed -> DateTime
dateTimeFromUnixEpoch :: Elapsed -> DateTime
dateTimeFromUnixEpoch Elapsed
e = CTm -> DateTime
fromC (CTm -> DateTime) -> CTm -> DateTime
forall a b. (a -> b) -> a -> b
$ Elapsed -> CTm
rawGmTime Elapsed
e

-- | Return the timezone offset in minutes.

systemGetTimezone :: IO TimezoneOffset
systemGetTimezone :: IO TimezoneOffset
systemGetTimezone = Int -> TimezoneOffset
TimezoneOffset (Int -> TimezoneOffset)
-> (CLong -> Int) -> CLong -> TimezoneOffset
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CLong -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CLong -> Int) -> (CLong -> CLong) -> CLong -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CLong -> CLong -> CLong) -> CLong -> CLong -> CLong
forall a b c. (a -> b -> c) -> b -> a -> c
flip CLong -> CLong -> CLong
forall a. Integral a => a -> a -> a
div CLong
60 (CLong -> TimezoneOffset) -> IO CLong -> IO TimezoneOffset
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Elapsed -> IO CLong
localTime Elapsed
0

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

-- | Return the current elapsedP.

systemGetElapsedP :: IO ElapsedP
systemGetElapsedP :: IO ElapsedP
systemGetElapsedP = Int -> Int -> (Ptr CLong -> IO ElapsedP) -> IO ElapsedP
forall a b. Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned Int
sofTimespec Int
8 ((Ptr CLong -> IO ElapsedP) -> IO ElapsedP)
-> (Ptr CLong -> IO ElapsedP) -> IO ElapsedP
forall a b. (a -> b) -> a -> b
$ \Ptr CLong
ptr -> do
  Ptr CLong -> IO ()
c_clock_get Ptr CLong
ptr
  CTime -> CLong -> ElapsedP
toElapsedP (CTime -> CLong -> ElapsedP) -> IO CTime -> IO (CLong -> ElapsedP)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CTime -> IO CTime
forall a. Storable a => Ptr a -> IO a
peek (Ptr CLong -> Ptr CTime
forall a b. Ptr a -> Ptr b
castPtr Ptr CLong
ptr) IO (CLong -> ElapsedP) -> IO CLong -> IO ElapsedP
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr CLong -> Int -> IO CLong
forall b. Ptr b -> Int -> IO CLong
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CLong
ptr Int
sofCTime
 where
  sofTimespec :: Int
sofTimespec = Int
sofCTime Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sofCLong
  sofCTime :: Int
sofCTime = CTime -> Int
forall a. Storable a => a -> Int
sizeOf (CTime
0 :: CTime)
  sofCLong :: Int
sofCLong = CLong -> Int
forall a. Storable a => a -> Int
sizeOf (CLong
0 :: CLong)
  toElapsedP :: CTime -> CLong -> ElapsedP
  toElapsedP :: CTime -> CLong -> ElapsedP
toElapsedP (CTime Int64
sec) CLong
nsec =
    Elapsed -> NanoSeconds -> ElapsedP
ElapsedP (Seconds -> Elapsed
Elapsed (Seconds -> Elapsed) -> Seconds -> Elapsed
forall a b. (a -> b) -> a -> b
$ Int64 -> Seconds
Seconds (Int64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
sec)) (CLong -> NanoSeconds
forall a b. (Integral a, Num b) => a -> b
fromIntegral CLong
nsec)

-- | Return the current elapsed.

systemGetElapsed :: IO Elapsed
systemGetElapsed :: IO Elapsed
systemGetElapsed = Int -> Int -> (Ptr CLong -> IO Elapsed) -> IO Elapsed
forall a b. Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned Int
sofTimespec Int
8 ((Ptr CLong -> IO Elapsed) -> IO Elapsed)
-> (Ptr CLong -> IO Elapsed) -> IO Elapsed
forall a b. (a -> b) -> a -> b
$ \Ptr CLong
ptr -> do
  Ptr CLong -> IO ()
c_clock_get Ptr CLong
ptr
  CTime -> Elapsed
toElapsed (CTime -> Elapsed) -> IO CTime -> IO Elapsed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CTime -> IO CTime
forall a. Storable a => Ptr a -> IO a
peek (Ptr CLong -> Ptr CTime
forall a b. Ptr a -> Ptr b
castPtr Ptr CLong
ptr)
 where
  sofTimespec :: Int
sofTimespec = CTime -> Int
forall a. Storable a => a -> Int
sizeOf (CTime
0 :: CTime) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CLong -> Int
forall a. Storable a => a -> Int
sizeOf (CLong
0 :: CLong)
  toElapsed :: CTime -> Elapsed
  toElapsed :: CTime -> Elapsed
toElapsed (CTime Int64
sec) = Seconds -> Elapsed
Elapsed (Seconds -> Elapsed) -> Seconds -> Elapsed
forall a b. (a -> b) -> a -> b
$ Int64 -> Seconds
Seconds (Int64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
sec)

foreign import ccall unsafe "hourglass_clock_calendar"
  c_clock_get :: Ptr CLong -> IO ()

foreign import ccall unsafe "gmtime_r"
  c_gmtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm)

foreign import ccall unsafe "localtime_r"
  c_localtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm)

-- | Return a global time's struct tm based on the number of elapsed second

-- since the start of the Unix epoch (1970-01-01 00:00:00 UTC).

rawGmTime :: Elapsed -> CTm
rawGmTime :: Elapsed -> CTm
rawGmTime (Elapsed (Seconds Int64
s)) = IO CTm -> CTm
forall a. IO a -> a
unsafePerformIO IO CTm
callTime
 where
  callTime :: IO CTm
callTime =
    (Ptr CTm -> IO CTm) -> IO CTm
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CTm -> IO CTm) -> IO CTm) -> (Ptr CTm -> IO CTm) -> IO CTm
forall a b. (a -> b) -> a -> b
$ \Ptr CTm
ctmPtr -> do
    (Ptr CTime -> IO CTm) -> IO CTm
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CTime -> IO CTm) -> IO CTm)
-> (Ptr CTime -> IO CTm) -> IO CTm
forall a b. (a -> b) -> a -> b
$ \Ptr CTime
ctimePtr -> do
      Ptr CTime -> CTime -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CTime
ctimePtr CTime
ctime
      Ptr CTm
r <- Ptr CTime -> Ptr CTm -> IO (Ptr CTm)
c_gmtime_r Ptr CTime
ctimePtr Ptr CTm
ctmPtr
      if Ptr CTm
r Ptr CTm -> Ptr CTm -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CTm
forall a. Ptr a
nullPtr
        then [Char] -> IO CTm
forall a. HasCallStack => [Char] -> a
error [Char]
"gmTime failed"
        else Ptr CTm -> IO CTm
forall a. Storable a => Ptr a -> IO a
peek Ptr CTm
ctmPtr
  ctime :: CTime
ctime = Int64 -> CTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
s
{-# NOINLINE rawGmTime #-}

-- | Return a local time's gmtoff (seconds east of UTC).

--

-- Use the ill-defined gmtoff (at offset 40) that might or might not be

-- available for your platform. Worst case scenario it's not initialized

-- properly.

localTime :: Elapsed -> IO CLong
localTime :: Elapsed -> IO CLong
localTime (Elapsed (Seconds Int64
s)) = IO CLong
callTime
 where
  callTime :: IO CLong
callTime =
    (Ptr CTm -> IO CLong) -> IO CLong
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CTm -> IO CLong) -> IO CLong)
-> (Ptr CTm -> IO CLong) -> IO CLong
forall a b. (a -> b) -> a -> b
$ \Ptr CTm
ctmPtr -> do
    (Ptr CTime -> IO CLong) -> IO CLong
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CTime -> IO CLong) -> IO CLong)
-> (Ptr CTime -> IO CLong) -> IO CLong
forall a b. (a -> b) -> a -> b
$ \Ptr CTime
ctimePtr -> do
      Ptr CTime -> CTime -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CTime
ctimePtr CTime
ctime
      Ptr CTm
r <- Ptr CTime -> Ptr CTm -> IO (Ptr CTm)
c_localtime_r Ptr CTime
ctimePtr Ptr CTm
ctmPtr
      if Ptr CTm
r Ptr CTm -> Ptr CTm -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CTm
forall a. Ptr a
nullPtr
        then [Char] -> IO CLong
forall a. HasCallStack => [Char] -> a
error [Char]
"localTime failed"
        else Ptr CTm -> Int -> IO CLong
forall b. Ptr b -> Int -> IO CLong
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr CTm
ctmPtr Int
40
  ctime :: CTime
ctime = Int64 -> CTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
s

-- | Represent the beginning of struct tm.

data CTm = CTm
  { CTm -> CInt
ctmSec    :: CInt
  , CTm -> CInt
ctmMin    :: CInt
  , CTm -> CInt
ctmHour   :: CInt
  , CTm -> CInt
ctmMDay   :: CInt
  , CTm -> CInt
ctmMon    :: CInt
  , CTm -> CInt
ctmYear   :: CInt
  }
  deriving (CTm -> CTm -> Bool
(CTm -> CTm -> Bool) -> (CTm -> CTm -> Bool) -> Eq CTm
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CTm -> CTm -> Bool
== :: CTm -> CTm -> Bool
$c/= :: CTm -> CTm -> Bool
/= :: CTm -> CTm -> Bool
Eq, Int -> CTm -> ShowS
[CTm] -> ShowS
CTm -> [Char]
(Int -> CTm -> ShowS)
-> (CTm -> [Char]) -> ([CTm] -> ShowS) -> Show CTm
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CTm -> ShowS
showsPrec :: Int -> CTm -> ShowS
$cshow :: CTm -> [Char]
show :: CTm -> [Char]
$cshowList :: [CTm] -> ShowS
showList :: [CTm] -> ShowS
Show)

-- | Convert a C structure to a DateTime structure.

fromC :: CTm -> DateTime
fromC :: CTm -> DateTime
fromC CTm
ctm = Date -> TimeOfDay -> DateTime
DateTime Date
date TimeOfDay
time
 where
  date :: Date
date = Date
    { dateYear :: Int
dateYear  = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> CInt -> Int
forall a b. (a -> b) -> a -> b
$ CTm -> CInt
ctmYear CTm
ctm CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
+ CInt
1900
    , dateMonth :: Month
dateMonth = Int -> Month
forall a. Enum a => Int -> a
toEnum (Int -> Month) -> Int -> Month
forall a b. (a -> b) -> a -> b
$ CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> CInt -> Int
forall a b. (a -> b) -> a -> b
$ CTm -> CInt
ctmMon CTm
ctm
    , dateDay :: Int
dateDay   = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> CInt -> Int
forall a b. (a -> b) -> a -> b
$ CTm -> CInt
ctmMDay CTm
ctm
    }
  time :: TimeOfDay
time = TimeOfDay
    { todHour :: Hours
todHour = CInt -> Hours
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Hours) -> CInt -> Hours
forall a b. (a -> b) -> a -> b
$ CTm -> CInt
ctmHour CTm
ctm
    , todMin :: Minutes
todMin  = CInt -> Minutes
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Minutes) -> CInt -> Minutes
forall a b. (a -> b) -> a -> b
$ CTm -> CInt
ctmMin CTm
ctm
    , todSec :: Seconds
todSec  = CInt -> Seconds
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Seconds) -> CInt -> Seconds
forall a b. (a -> b) -> a -> b
$ CTm -> CInt
ctmSec CTm
ctm
    , todNSec :: NanoSeconds
todNSec = NanoSeconds
0
    }

-- | Similar to 'fromC' except with nanosecond precision.

fromCP :: NanoSeconds -> CTm -> DateTime
fromCP :: NanoSeconds -> CTm -> DateTime
fromCP NanoSeconds
ns CTm
ctm = Date -> TimeOfDay -> DateTime
DateTime Date
d (TimeOfDay
t { todNSec = ns })
 where
  (DateTime Date
d TimeOfDay
t) = CTm -> DateTime
fromC CTm
ctm

instance Storable CTm where
  alignment :: CTm -> Int
alignment CTm
_ = Int
8
  sizeOf :: CTm -> Int
sizeOf CTm
_    = Int
60 -- account for 9 ints, alignment + 2 unsigned long at end.

  peek :: Ptr CTm -> IO CTm
peek Ptr CTm
ptr    = do
    CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CTm
CTm (CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CTm)
-> IO CInt -> IO (CInt -> CInt -> CInt -> CInt -> CInt -> CTm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Any -> Int -> IO CInt
forall b. Ptr b -> Int -> IO CInt
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Any
forall a. Ptr a
intPtr Int
0
        IO (CInt -> CInt -> CInt -> CInt -> CInt -> CTm)
-> IO CInt -> IO (CInt -> CInt -> CInt -> CInt -> CTm)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr Any -> Int -> IO CInt
forall b. Ptr b -> Int -> IO CInt
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Any
forall a. Ptr a
intPtr Int
4
        IO (CInt -> CInt -> CInt -> CInt -> CTm)
-> IO CInt -> IO (CInt -> CInt -> CInt -> CTm)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr Any -> Int -> IO CInt
forall b. Ptr b -> Int -> IO CInt
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Any
forall a. Ptr a
intPtr Int
8
        IO (CInt -> CInt -> CInt -> CTm)
-> IO CInt -> IO (CInt -> CInt -> CTm)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr Any -> Int -> IO CInt
forall b. Ptr b -> Int -> IO CInt
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Any
forall a. Ptr a
intPtr Int
12
        IO (CInt -> CInt -> CTm) -> IO CInt -> IO (CInt -> CTm)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr Any -> Int -> IO CInt
forall b. Ptr b -> Int -> IO CInt
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Any
forall a. Ptr a
intPtr Int
16
        IO (CInt -> CTm) -> IO CInt -> IO CTm
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr Any -> Int -> IO CInt
forall b. Ptr b -> Int -> IO CInt
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Any
forall a. Ptr a
intPtr Int
20
   where
    intPtr :: Ptr b
intPtr = Ptr CTm -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr Ptr CTm
ptr
  poke :: Ptr CTm -> CTm -> IO ()
poke Ptr CTm
ptr (CTm CInt
f0 CInt
f1 CInt
f2 CInt
f3 CInt
f4 CInt
f5) = do
    ((Int, CInt) -> IO ()) -> [(Int, CInt)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
      ((Int -> CInt -> IO ()) -> (Int, CInt) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Ptr Any -> Int -> CInt -> IO ()
forall b. Ptr b -> Int -> CInt -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Any
forall a. Ptr a
intPtr))
      [(Int
0, CInt
f0), (Int
4, CInt
f1), (Int
8, CInt
f2), (Int
12, CInt
f3), (Int
16, CInt
f4), (Int
20, CInt
f5)]
    --pokeByteOff (castPtr ptr) 36 f9

   where
    intPtr :: Ptr b
intPtr = Ptr CTm -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr Ptr CTm
ptr