{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

module Stack.Types.Cache
  ( ConfigCacheType (..)
  , Action (..)
  ) where

import qualified Data.Text as T
import           Database.Persist.Sql
                   ( PersistField (..), PersistFieldSql (..), PersistValue (..)
                   , SqlType (..)
                   )
import           Stack.Prelude
import           Stack.Types.GhcPkgId ( GhcPkgId, parseGhcPkgId, unGhcPkgId )

-- | Type of config cache

data ConfigCacheType
  = ConfigCacheTypeConfig
  | ConfigCacheTypeFlagLibrary GhcPkgId
  | ConfigCacheTypeFlagExecutable PackageIdentifier
  deriving (ConfigCacheType -> ConfigCacheType -> Bool
(ConfigCacheType -> ConfigCacheType -> Bool)
-> (ConfigCacheType -> ConfigCacheType -> Bool)
-> Eq ConfigCacheType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConfigCacheType -> ConfigCacheType -> Bool
== :: ConfigCacheType -> ConfigCacheType -> Bool
$c/= :: ConfigCacheType -> ConfigCacheType -> Bool
/= :: ConfigCacheType -> ConfigCacheType -> Bool
Eq, Int -> ConfigCacheType -> ShowS
[ConfigCacheType] -> ShowS
ConfigCacheType -> String
(Int -> ConfigCacheType -> ShowS)
-> (ConfigCacheType -> String)
-> ([ConfigCacheType] -> ShowS)
-> Show ConfigCacheType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConfigCacheType -> ShowS
showsPrec :: Int -> ConfigCacheType -> ShowS
$cshow :: ConfigCacheType -> String
show :: ConfigCacheType -> String
$cshowList :: [ConfigCacheType] -> ShowS
showList :: [ConfigCacheType] -> ShowS
Show)

instance PersistField ConfigCacheType where
  toPersistValue :: ConfigCacheType -> PersistValue
toPersistValue ConfigCacheType
ConfigCacheTypeConfig = Text -> PersistValue
PersistText Text
"config"
  toPersistValue (ConfigCacheTypeFlagLibrary GhcPkgId
v) =
    Text -> PersistValue
PersistText (Text -> PersistValue) -> Text -> PersistValue
forall a b. (a -> b) -> a -> b
$ Text
"lib:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GhcPkgId -> Text
unGhcPkgId GhcPkgId
v
  toPersistValue (ConfigCacheTypeFlagExecutable PackageIdentifier
v) =
    Text -> PersistValue
PersistText (Text -> PersistValue) -> Text -> PersistValue
forall a b. (a -> b) -> a -> b
$ Text
"exe:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (PackageIdentifier -> String
packageIdentifierString PackageIdentifier
v)
  fromPersistValue :: PersistValue -> Either Text ConfigCacheType
fromPersistValue (PersistText Text
t) =
    Either Text ConfigCacheType
-> Maybe (Either Text ConfigCacheType)
-> Either Text ConfigCacheType
forall a. a -> Maybe a -> a
fromMaybe (Text -> Either Text ConfigCacheType
forall a b. a -> Either a b
Left (Text -> Either Text ConfigCacheType)
-> Text -> Either Text ConfigCacheType
forall a b. (a -> b) -> a -> b
$ Text
"Unexpected ConfigCacheType value: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t) (Maybe (Either Text ConfigCacheType)
 -> Either Text ConfigCacheType)
-> Maybe (Either Text ConfigCacheType)
-> Either Text ConfigCacheType
forall a b. (a -> b) -> a -> b
$
    Maybe (Either Text ConfigCacheType)
forall {a}. Maybe (Either a ConfigCacheType)
config Maybe (Either Text ConfigCacheType)
-> Maybe (Either Text ConfigCacheType)
-> Maybe (Either Text ConfigCacheType)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Either Text ConfigCacheType)
-> Maybe Text -> Maybe (Either Text ConfigCacheType)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Either Text ConfigCacheType
lib (Text -> Text -> Maybe Text
T.stripPrefix Text
"lib:" Text
t) Maybe (Either Text ConfigCacheType)
-> Maybe (Either Text ConfigCacheType)
-> Maybe (Either Text ConfigCacheType)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
    (Text -> Either Text ConfigCacheType)
-> Maybe Text -> Maybe (Either Text ConfigCacheType)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Either Text ConfigCacheType
exe (Text -> Text -> Maybe Text
T.stripPrefix Text
"exe:" Text
t)
   where
    config :: Maybe (Either a ConfigCacheType)
config
      | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"config" = Either a ConfigCacheType -> Maybe (Either a ConfigCacheType)
forall a. a -> Maybe a
Just (ConfigCacheType -> Either a ConfigCacheType
forall a b. b -> Either a b
Right ConfigCacheType
ConfigCacheTypeConfig)
      | Bool
otherwise = Maybe (Either a ConfigCacheType)
forall a. Maybe a
Nothing
    lib :: Text -> Either Text ConfigCacheType
lib Text
v = do
      GhcPkgId
ghcPkgId <- (SomeException -> Text)
-> Either SomeException GhcPkgId -> Either Text GhcPkgId
forall a1 a2 b. (a1 -> a2) -> Either a1 b -> Either a2 b
mapLeft SomeException -> Text
forall a. Show a => a -> Text
tshow (Text -> Either SomeException GhcPkgId
forall (m :: * -> *). MonadThrow m => Text -> m GhcPkgId
parseGhcPkgId Text
v)
      ConfigCacheType -> Either Text ConfigCacheType
forall a b. b -> Either a b
Right (ConfigCacheType -> Either Text ConfigCacheType)
-> ConfigCacheType -> Either Text ConfigCacheType
forall a b. (a -> b) -> a -> b
$ GhcPkgId -> ConfigCacheType
ConfigCacheTypeFlagLibrary GhcPkgId
ghcPkgId
    exe :: Text -> Either Text ConfigCacheType
exe Text
v = do
      PackageIdentifier
pkgId <-
        Either Text PackageIdentifier
-> (PackageIdentifier -> Either Text PackageIdentifier)
-> Maybe PackageIdentifier
-> Either Text PackageIdentifier
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text PackageIdentifier
forall a b. a -> Either a b
Left (Text -> Either Text PackageIdentifier)
-> Text -> Either Text PackageIdentifier
forall a b. (a -> b) -> a -> b
$ Text
"Unexpected ConfigCacheType value: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t) PackageIdentifier -> Either Text PackageIdentifier
forall a b. b -> Either a b
Right (Maybe PackageIdentifier -> Either Text PackageIdentifier)
-> Maybe PackageIdentifier -> Either Text PackageIdentifier
forall a b. (a -> b) -> a -> b
$
        String -> Maybe PackageIdentifier
parsePackageIdentifier (Text -> String
T.unpack Text
v)
      ConfigCacheType -> Either Text ConfigCacheType
forall a b. b -> Either a b
Right (ConfigCacheType -> Either Text ConfigCacheType)
-> ConfigCacheType -> Either Text ConfigCacheType
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> ConfigCacheType
ConfigCacheTypeFlagExecutable PackageIdentifier
pkgId
  fromPersistValue PersistValue
_ = Text -> Either Text ConfigCacheType
forall a b. a -> Either a b
Left Text
"Unexpected ConfigCacheType type"

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

data Action
  = UpgradeCheck
  deriving (Action -> Action -> Bool
(Action -> Action -> Bool)
-> (Action -> Action -> Bool) -> Eq Action
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Action -> Action -> Bool
== :: Action -> Action -> Bool
$c/= :: Action -> Action -> Bool
/= :: Action -> Action -> Bool
Eq, Eq Action
Eq Action
-> (Action -> Action -> Ordering)
-> (Action -> Action -> Bool)
-> (Action -> Action -> Bool)
-> (Action -> Action -> Bool)
-> (Action -> Action -> Bool)
-> (Action -> Action -> Action)
-> (Action -> Action -> Action)
-> Ord Action
Action -> Action -> Bool
Action -> Action -> Ordering
Action -> Action -> Action
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 :: Action -> Action -> Ordering
compare :: Action -> Action -> Ordering
$c< :: Action -> Action -> Bool
< :: Action -> Action -> Bool
$c<= :: Action -> Action -> Bool
<= :: Action -> Action -> Bool
$c> :: Action -> Action -> Bool
> :: Action -> Action -> Bool
$c>= :: Action -> Action -> Bool
>= :: Action -> Action -> Bool
$cmax :: Action -> Action -> Action
max :: Action -> Action -> Action
$cmin :: Action -> Action -> Action
min :: Action -> Action -> Action
Ord, Int -> Action -> ShowS
[Action] -> ShowS
Action -> String
(Int -> Action -> ShowS)
-> (Action -> String) -> ([Action] -> ShowS) -> Show Action
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Action -> ShowS
showsPrec :: Int -> Action -> ShowS
$cshow :: Action -> String
show :: Action -> String
$cshowList :: [Action] -> ShowS
showList :: [Action] -> ShowS
Show)

instance PersistField Action where
  toPersistValue :: Action -> PersistValue
toPersistValue Action
UpgradeCheck = Int64 -> PersistValue
PersistInt64 Int64
1
  fromPersistValue :: PersistValue -> Either Text Action
fromPersistValue (PersistInt64 Int64
1) = Action -> Either Text Action
forall a b. b -> Either a b
Right Action
UpgradeCheck
  fromPersistValue PersistValue
x = Text -> Either Text Action
forall a b. a -> Either a b
Left (Text -> Either Text Action) -> Text -> Either Text Action
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Invalid Action: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PersistValue -> String
forall a. Show a => a -> String
show PersistValue
x

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