{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# OPTIONS_GHC -fno-warn-orphans       #-}

module System.Nix.Store.DB.Instances where

import Database.Persist (PersistField(..), PersistValue(..), SqlType(..))
import Database.Persist.Sql (PersistFieldSql(..))

import Data.Time (UTCTime)
import Data.Default.Class (Default(def))

import System.Nix.ContentAddress (ContentAddress)
import System.Nix.StorePath (StorePath)
import System.Nix.StorePath.Metadata (StorePathTrust(..))

import qualified Data.Attoparsec.Text
import qualified Data.Bifunctor
import qualified Data.Text
import qualified Data.Time.Clock.POSIX

import qualified System.Nix.ContentAddress
import qualified System.Nix.StorePath

instance PersistField StorePath where
  toPersistValue :: StorePath -> PersistValue
toPersistValue = Text -> PersistValue
PersistText (Text -> PersistValue)
-> (StorePath -> Text) -> StorePath -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreDir -> StorePath -> Text
System.Nix.StorePath.storePathToText StoreDir
forall a. Default a => a
def
  fromPersistValue :: PersistValue -> Either Text StorePath
fromPersistValue (PersistText Text
t) = (String -> Either Text StorePath)
-> (StorePath -> Either Text StorePath)
-> Either String StorePath
-> Either Text StorePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (Text -> Either Text StorePath
forall a b. a -> Either a b
Left (Text -> Either Text StorePath)
-> (String -> Text) -> String -> Either Text StorePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Data.Text.pack)
    StorePath -> Either Text StorePath
forall a b. b -> Either a b
Right
    (Either String StorePath -> Either Text StorePath)
-> Either String StorePath -> Either Text StorePath
forall a b. (a -> b) -> a -> b
$ Parser StorePath -> Text -> Either String StorePath
forall a. Parser a -> Text -> Either String a
Data.Attoparsec.Text.parseOnly
      (StoreDir -> Parser StorePath
System.Nix.StorePath.pathParser StoreDir
forall a. Default a => a
def)
      Text
t
  fromPersistValue PersistValue
wrongValue = Text -> Either Text StorePath
forall a b. a -> Either a b
Left
    (Text -> Either Text StorePath) -> Text -> Either Text StorePath
forall a b. (a -> b) -> a -> b
$ Text
"Received "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Data.Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PersistValue -> String
forall a. Show a => a -> String
show PersistValue
wrongValue)
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" when a value of type PersistText was expected."

instance PersistFieldSql StorePath where
  sqlType :: Proxy StorePath -> SqlType
sqlType Proxy StorePath
_ = SqlType
SqlString

instance PersistField StorePathTrust where
  toPersistValue :: StorePathTrust -> PersistValue
toPersistValue StorePathTrust
BuiltLocally     = Int64 -> PersistValue
PersistInt64 Int64
1
  toPersistValue StorePathTrust
BuiltElsewhere   = PersistValue
PersistNull

  fromPersistValue :: PersistValue -> Either Text StorePathTrust
fromPersistValue (PersistInt64 Int64
1) = StorePathTrust -> Either Text StorePathTrust
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StorePathTrust
BuiltLocally
  fromPersistValue PersistValue
PersistNull      = StorePathTrust -> Either Text StorePathTrust
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StorePathTrust
BuiltElsewhere
  fromPersistValue PersistValue
wrongValue = Text -> Either Text StorePathTrust
forall a b. a -> Either a b
Left
    (Text -> Either Text StorePathTrust)
-> Text -> Either Text StorePathTrust
forall a b. (a -> b) -> a -> b
$ Text
"Received "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Data.Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PersistValue -> String
forall a. Show a => a -> String
show PersistValue
wrongValue)
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" when a value of type PersistNull"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" or (PersistInt64 1) was expected."

instance PersistFieldSql StorePathTrust where
  sqlType :: Proxy StorePathTrust -> SqlType
sqlType Proxy StorePathTrust
_ = SqlType
SqlInt64

newtype NixUTCTime = NixUTCTime UTCTime
  deriving (NixUTCTime -> NixUTCTime -> Bool
(NixUTCTime -> NixUTCTime -> Bool)
-> (NixUTCTime -> NixUTCTime -> Bool) -> Eq NixUTCTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NixUTCTime -> NixUTCTime -> Bool
== :: NixUTCTime -> NixUTCTime -> Bool
$c/= :: NixUTCTime -> NixUTCTime -> Bool
/= :: NixUTCTime -> NixUTCTime -> Bool
Eq, Int -> NixUTCTime -> ShowS
[NixUTCTime] -> ShowS
NixUTCTime -> String
(Int -> NixUTCTime -> ShowS)
-> (NixUTCTime -> String)
-> ([NixUTCTime] -> ShowS)
-> Show NixUTCTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NixUTCTime -> ShowS
showsPrec :: Int -> NixUTCTime -> ShowS
$cshow :: NixUTCTime -> String
show :: NixUTCTime -> String
$cshowList :: [NixUTCTime] -> ShowS
showList :: [NixUTCTime] -> ShowS
Show, Eq NixUTCTime
Eq NixUTCTime =>
(NixUTCTime -> NixUTCTime -> Ordering)
-> (NixUTCTime -> NixUTCTime -> Bool)
-> (NixUTCTime -> NixUTCTime -> Bool)
-> (NixUTCTime -> NixUTCTime -> Bool)
-> (NixUTCTime -> NixUTCTime -> Bool)
-> (NixUTCTime -> NixUTCTime -> NixUTCTime)
-> (NixUTCTime -> NixUTCTime -> NixUTCTime)
-> Ord NixUTCTime
NixUTCTime -> NixUTCTime -> Bool
NixUTCTime -> NixUTCTime -> Ordering
NixUTCTime -> NixUTCTime -> NixUTCTime
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NixUTCTime -> NixUTCTime -> Ordering
compare :: NixUTCTime -> NixUTCTime -> Ordering
$c< :: NixUTCTime -> NixUTCTime -> Bool
< :: NixUTCTime -> NixUTCTime -> Bool
$c<= :: NixUTCTime -> NixUTCTime -> Bool
<= :: NixUTCTime -> NixUTCTime -> Bool
$c> :: NixUTCTime -> NixUTCTime -> Bool
> :: NixUTCTime -> NixUTCTime -> Bool
$c>= :: NixUTCTime -> NixUTCTime -> Bool
>= :: NixUTCTime -> NixUTCTime -> Bool
$cmax :: NixUTCTime -> NixUTCTime -> NixUTCTime
max :: NixUTCTime -> NixUTCTime -> NixUTCTime
$cmin :: NixUTCTime -> NixUTCTime -> NixUTCTime
min :: NixUTCTime -> NixUTCTime -> NixUTCTime
Ord)

instance PersistField NixUTCTime where
  toPersistValue :: NixUTCTime -> PersistValue
toPersistValue (NixUTCTime UTCTime
u) = Int64 -> PersistValue
PersistInt64
    (Int64 -> PersistValue) -> Int64 -> PersistValue
forall a b. (a -> b) -> a -> b
$ POSIXTime -> Int64
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Int64) -> POSIXTime -> Int64
forall a b. (a -> b) -> a -> b
$  UTCTime -> POSIXTime
Data.Time.Clock.POSIX.utcTimeToPOSIXSeconds UTCTime
u
  fromPersistValue :: PersistValue -> Either Text NixUTCTime
fromPersistValue (PersistInt64 Int64
i) = NixUTCTime -> Either Text NixUTCTime
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NixUTCTime -> Either Text NixUTCTime)
-> NixUTCTime -> Either Text NixUTCTime
forall a b. (a -> b) -> a -> b
$ UTCTime -> NixUTCTime
NixUTCTime
    (UTCTime -> NixUTCTime) -> UTCTime -> NixUTCTime
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
Data.Time.Clock.POSIX.posixSecondsToUTCTime (POSIXTime -> UTCTime) -> POSIXTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Int64 -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
  fromPersistValue PersistValue
wrongValue = Text -> Either Text NixUTCTime
forall a b. a -> Either a b
Left
    (Text -> Either Text NixUTCTime) -> Text -> Either Text NixUTCTime
forall a b. (a -> b) -> a -> b
$ Text
"Received "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Data.Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PersistValue -> String
forall a. Show a => a -> String
show PersistValue
wrongValue)
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" when a value of (PersistInt64 _) was expected."

instance PersistFieldSql NixUTCTime where
  sqlType :: Proxy NixUTCTime -> SqlType
sqlType Proxy NixUTCTime
_ = SqlType
SqlInt64

instance PersistField ContentAddress where
  toPersistValue :: ContentAddress -> PersistValue
toPersistValue =
    Text -> PersistValue
PersistText
    (Text -> PersistValue)
-> (ContentAddress -> Text) -> ContentAddress -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentAddress -> Text
System.Nix.ContentAddress.buildContentAddress

  fromPersistValue :: PersistValue -> Either Text ContentAddress
fromPersistValue (PersistText Text
t) =
    (String -> Text)
-> Either String ContentAddress -> Either Text ContentAddress
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Data.Bifunctor.first (\String
e -> String -> Text
forall a. HasCallStack => String -> a
error (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (String, Text) -> String
forall a. Show a => a -> String
show (String
e, Text
t))
    (Either String ContentAddress -> Either Text ContentAddress)
-> Either String ContentAddress -> Either Text ContentAddress
forall a b. (a -> b) -> a -> b
$ Text -> Either String ContentAddress
System.Nix.ContentAddress.parseContentAddress Text
t
  fromPersistValue PersistValue
wrongValue = Text -> Either Text ContentAddress
forall a b. a -> Either a b
Left
    (Text -> Either Text ContentAddress)
-> Text -> Either Text ContentAddress
forall a b. (a -> b) -> a -> b
$ Text
"Received "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
Data.Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PersistValue -> String
forall a. Show a => a -> String
show PersistValue
wrongValue)
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" when a value of type PersistText was expected."

instance PersistFieldSql ContentAddress where
  sqlType :: Proxy ContentAddress -> SqlType
sqlType Proxy ContentAddress
_ = SqlType
SqlString