module StatusNotifier.Watcher.StateCache
  ( PersistedItemEntry (..)
  , PersistedWatcherState (..)
  , defaultWatcherStateCachePath
  , readPersistedWatcherState
  , writePersistedWatcherState
  ) where

import Control.Applicative ((<|>))
import Control.Exception (IOException, try)
import Data.Char (isAlphaNum, isDigit)
import Data.List (intercalate)
import System.Directory
  ( XdgDirectory (XdgCache)
  , createDirectoryIfMissing
  , doesFileExist
  , getXdgDirectory
  , renameFile
  )
import System.FilePath ((</>), takeDirectory)
import Text.ParserCombinators.ReadP
  ( ReadP
  , char
  , choice
  , eof
  , many
  , munch
  , readP_to_S
  , satisfy
  , sepBy
  , skipSpaces
  )

data PersistedItemEntry = PersistedItemEntry
  { PersistedItemEntry -> String
persistedServiceName :: String
  , PersistedItemEntry -> String
persistedServicePath :: String
  } deriving (PersistedItemEntry -> PersistedItemEntry -> Bool
(PersistedItemEntry -> PersistedItemEntry -> Bool)
-> (PersistedItemEntry -> PersistedItemEntry -> Bool)
-> Eq PersistedItemEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PersistedItemEntry -> PersistedItemEntry -> Bool
== :: PersistedItemEntry -> PersistedItemEntry -> Bool
$c/= :: PersistedItemEntry -> PersistedItemEntry -> Bool
/= :: PersistedItemEntry -> PersistedItemEntry -> Bool
Eq, Int -> PersistedItemEntry -> ShowS
[PersistedItemEntry] -> ShowS
PersistedItemEntry -> String
(Int -> PersistedItemEntry -> ShowS)
-> (PersistedItemEntry -> String)
-> ([PersistedItemEntry] -> ShowS)
-> Show PersistedItemEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PersistedItemEntry -> ShowS
showsPrec :: Int -> PersistedItemEntry -> ShowS
$cshow :: PersistedItemEntry -> String
show :: PersistedItemEntry -> String
$cshowList :: [PersistedItemEntry] -> ShowS
showList :: [PersistedItemEntry] -> ShowS
Show)

data PersistedWatcherState = PersistedWatcherState
  { PersistedWatcherState -> [PersistedItemEntry]
persistedItems :: [PersistedItemEntry]
  , PersistedWatcherState -> [PersistedItemEntry]
persistedHosts :: [PersistedItemEntry]
  } deriving (PersistedWatcherState -> PersistedWatcherState -> Bool
(PersistedWatcherState -> PersistedWatcherState -> Bool)
-> (PersistedWatcherState -> PersistedWatcherState -> Bool)
-> Eq PersistedWatcherState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PersistedWatcherState -> PersistedWatcherState -> Bool
== :: PersistedWatcherState -> PersistedWatcherState -> Bool
$c/= :: PersistedWatcherState -> PersistedWatcherState -> Bool
/= :: PersistedWatcherState -> PersistedWatcherState -> Bool
Eq, Int -> PersistedWatcherState -> ShowS
[PersistedWatcherState] -> ShowS
PersistedWatcherState -> String
(Int -> PersistedWatcherState -> ShowS)
-> (PersistedWatcherState -> String)
-> ([PersistedWatcherState] -> ShowS)
-> Show PersistedWatcherState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PersistedWatcherState -> ShowS
showsPrec :: Int -> PersistedWatcherState -> ShowS
$cshow :: PersistedWatcherState -> String
show :: PersistedWatcherState -> String
$cshowList :: [PersistedWatcherState] -> ShowS
showList :: [PersistedWatcherState] -> ShowS
Show)

data JsonValue
  = JsonObject [(String, JsonValue)]
  | JsonArray [JsonValue]
  | JsonString String
  | JsonNumber Int
  deriving (JsonValue -> JsonValue -> Bool
(JsonValue -> JsonValue -> Bool)
-> (JsonValue -> JsonValue -> Bool) -> Eq JsonValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JsonValue -> JsonValue -> Bool
== :: JsonValue -> JsonValue -> Bool
$c/= :: JsonValue -> JsonValue -> Bool
/= :: JsonValue -> JsonValue -> Bool
Eq, Int -> JsonValue -> ShowS
[JsonValue] -> ShowS
JsonValue -> String
(Int -> JsonValue -> ShowS)
-> (JsonValue -> String)
-> ([JsonValue] -> ShowS)
-> Show JsonValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JsonValue -> ShowS
showsPrec :: Int -> JsonValue -> ShowS
$cshow :: JsonValue -> String
show :: JsonValue -> String
$cshowList :: [JsonValue] -> ShowS
showList :: [JsonValue] -> ShowS
Show)

defaultWatcherStateCachePath :: String -> String -> IO FilePath
defaultWatcherStateCachePath :: String -> String -> IO String
defaultWatcherStateCachePath String
interfaceNamespace String
path = do
  xdgCachePath <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgCache String
"status-notifier-item"
  let sanitize = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char -> Bool
isAlphaNum Char
c then Char
c else Char
'_')
      filename =
        String
"watcher-state-"
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
sanitize String
interfaceNamespace
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-"
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
sanitize String
path
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".json"
  pure $ xdgCachePath </> filename

writePersistedWatcherState :: FilePath -> PersistedWatcherState -> IO (Either String ())
writePersistedWatcherState :: String -> PersistedWatcherState -> IO (Either String ())
writePersistedWatcherState String
cachePath PersistedWatcherState
state = do
  let tempPath :: String
tempPath = String
cachePath String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".tmp"
      encodedState :: String
encodedState = PersistedWatcherState -> String
encodePersistedWatcherState PersistedWatcherState
state
  writeResult <-
    IO () -> IO (Either IOException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ do
      Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory String
cachePath)
      String -> String -> IO ()
writeFile String
tempPath String
encodedState
      String -> String -> IO ()
renameFile String
tempPath String
cachePath
  pure $
    case writeResult of
      Left IOException
err -> String -> Either String ()
forall a b. a -> Either a b
Left (IOException -> String
forall a. Show a => a -> String
show (IOException
err :: IOException))
      Right ()
_ -> () -> Either String ()
forall a b. b -> Either a b
Right ()

readPersistedWatcherState :: FilePath -> IO (Either String (Maybe PersistedWatcherState))
readPersistedWatcherState :: String -> IO (Either String (Maybe PersistedWatcherState))
readPersistedWatcherState String
cachePath = do
  exists <- String -> IO Bool
doesFileExist String
cachePath
  if not exists
    then pure $ Right Nothing
    else do
      readResult <- try (readFile cachePath) :: IO (Either IOException String)
      pure $
        case readResult of
          Left IOException
err -> String -> Either String (Maybe PersistedWatcherState)
forall a b. a -> Either a b
Left (IOException -> String
forall a. Show a => a -> String
show IOException
err)
          Right String
contents -> PersistedWatcherState -> Maybe PersistedWatcherState
forall a. a -> Maybe a
Just (PersistedWatcherState -> Maybe PersistedWatcherState)
-> Either String PersistedWatcherState
-> Either String (Maybe PersistedWatcherState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String PersistedWatcherState
decodePersistedWatcherState String
contents

encodePersistedWatcherState :: PersistedWatcherState -> String
encodePersistedWatcherState :: PersistedWatcherState -> String
encodePersistedWatcherState PersistedWatcherState
state =
  JsonValue -> String
encodeJsonValue (JsonValue -> String) -> JsonValue -> String
forall a b. (a -> b) -> a -> b
$
    [(String, JsonValue)] -> JsonValue
JsonObject
      [ (String
"version", Int -> JsonValue
JsonNumber Int
1)
      , (String
"items", [JsonValue] -> JsonValue
JsonArray ([JsonValue] -> JsonValue) -> [JsonValue] -> JsonValue
forall a b. (a -> b) -> a -> b
$ (PersistedItemEntry -> JsonValue)
-> [PersistedItemEntry] -> [JsonValue]
forall a b. (a -> b) -> [a] -> [b]
map PersistedItemEntry -> JsonValue
encodeItemEntry (PersistedWatcherState -> [PersistedItemEntry]
persistedItems PersistedWatcherState
state))
      , (String
"hosts", [JsonValue] -> JsonValue
JsonArray ([JsonValue] -> JsonValue) -> [JsonValue] -> JsonValue
forall a b. (a -> b) -> a -> b
$ (PersistedItemEntry -> JsonValue)
-> [PersistedItemEntry] -> [JsonValue]
forall a b. (a -> b) -> [a] -> [b]
map PersistedItemEntry -> JsonValue
encodeItemEntry (PersistedWatcherState -> [PersistedItemEntry]
persistedHosts PersistedWatcherState
state))
      ]

encodeItemEntry :: PersistedItemEntry -> JsonValue
encodeItemEntry :: PersistedItemEntry -> JsonValue
encodeItemEntry PersistedItemEntry
entry =
  [(String, JsonValue)] -> JsonValue
JsonObject
    [ (String
"service_name", String -> JsonValue
JsonString (PersistedItemEntry -> String
persistedServiceName PersistedItemEntry
entry))
    , (String
"service_path", String -> JsonValue
JsonString (PersistedItemEntry -> String
persistedServicePath PersistedItemEntry
entry))
    ]

decodePersistedWatcherState :: String -> Either String PersistedWatcherState
decodePersistedWatcherState :: String -> Either String PersistedWatcherState
decodePersistedWatcherState String
raw = do
  root <- String -> Either String JsonValue
parseJson String
raw
  rootObject <- asObject "root" root
  version <- getRequiredNumber "version" rootObject
  if version /= 1
    then Left "Unsupported watcher cache version."
    else do
      itemsValue <- getRequired "items" rootObject
      hostsValue <- getRequired "hosts" rootObject
      items <- asArray "items" itemsValue >>= mapM decodeItemEntry
      hosts <- asArray "hosts" hostsValue >>= mapM decodeItemEntry
      Right PersistedWatcherState
        { persistedItems = items
        , persistedHosts = hosts
        }

decodeItemEntry :: JsonValue -> Either String PersistedItemEntry
decodeItemEntry :: JsonValue -> Either String PersistedItemEntry
decodeItemEntry JsonValue
value = do
  obj <- String -> JsonValue -> Either String [(String, JsonValue)]
asObject String
"entry" JsonValue
value
  serviceName <- getRequiredString "service_name" obj
  servicePath <- getRequiredString "service_path" obj
  Right PersistedItemEntry
    { persistedServiceName = serviceName
    , persistedServicePath = servicePath
    }

encodeJsonValue :: JsonValue -> String
encodeJsonValue :: JsonValue -> String
encodeJsonValue JsonValue
json =
  case JsonValue
json of
    JsonObject [(String, JsonValue)]
fields ->
      String
"{"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (((String, JsonValue) -> String)
-> [(String, JsonValue)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, JsonValue) -> String
encodeField [(String, JsonValue)]
fields)
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"
      where
        encodeField :: (String, JsonValue) -> String
encodeField (String
name, JsonValue
value) =
          ShowS
encodeJsonString String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ JsonValue -> String
encodeJsonValue JsonValue
value
    JsonArray [JsonValue]
values ->
      String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((JsonValue -> String) -> [JsonValue] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map JsonValue -> String
encodeJsonValue [JsonValue]
values) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
    JsonString String
value ->
      ShowS
encodeJsonString String
value
    JsonNumber Int
number ->
      Int -> String
forall a. Show a => a -> String
show Int
number

encodeJsonString :: String -> String
encodeJsonString :: ShowS
encodeJsonString String
value =
  String
"\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
encodeChar String
value String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""
  where
    encodeChar :: Char -> String
encodeChar Char
'"' = String
"\\\""
    encodeChar Char
'\\' = String
"\\\\"
    encodeChar Char
'\n' = String
"\\n"
    encodeChar Char
'\r' = String
"\\r"
    encodeChar Char
'\t' = String
"\\t"
    encodeChar Char
c = [Char
c]

parseJson :: String -> Either String JsonValue
parseJson :: String -> Either String JsonValue
parseJson String
input =
  case [JsonValue
value | (JsonValue
value, String
rest) <- ReadP JsonValue -> ReadS JsonValue
forall a. ReadP a -> ReadS a
readP_to_S ReadP JsonValue
parseJsonDocument String
input, String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest] of
    [JsonValue
value] -> JsonValue -> Either String JsonValue
forall a b. b -> Either a b
Right JsonValue
value
    [] -> String -> Either String JsonValue
forall a b. a -> Either a b
Left String
"Failed to parse watcher cache JSON."
    [JsonValue]
_ -> String -> Either String JsonValue
forall a b. a -> Either a b
Left String
"Watcher cache JSON is ambiguous."

parseJsonDocument :: ReadP JsonValue
parseJsonDocument :: ReadP JsonValue
parseJsonDocument = do
  ReadP ()
skipSpaces
  value <- ReadP JsonValue
parseJsonValue
  skipSpaces
  eof
  return value

parseJsonValue :: ReadP JsonValue
parseJsonValue :: ReadP JsonValue
parseJsonValue = do
  ReadP ()
skipSpaces
  [ReadP JsonValue] -> ReadP JsonValue
forall a. [ReadP a] -> ReadP a
choice [ReadP JsonValue
parseJsonObject, ReadP JsonValue
parseJsonArray, String -> JsonValue
JsonString (String -> JsonValue) -> ReadP String -> ReadP JsonValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP String
parseJsonString, ReadP JsonValue
parseJsonNumber]

parseJsonObject :: ReadP JsonValue
parseJsonObject :: ReadP JsonValue
parseJsonObject = do
  _ <- Char -> ReadP Char
char Char
'{'
  skipSpaces
  fields <- sepBy parseJsonField (skipSpaces >> char ',' >> skipSpaces)
  skipSpaces
  _ <- char '}'
  return $ JsonObject fields

parseJsonField :: ReadP (String, JsonValue)
parseJsonField :: ReadP (String, JsonValue)
parseJsonField = do
  key <- ReadP String
parseJsonString
  skipSpaces
  _ <- char ':'
  skipSpaces
  value <- parseJsonValue
  return (key, value)

parseJsonArray :: ReadP JsonValue
parseJsonArray :: ReadP JsonValue
parseJsonArray = do
  _ <- Char -> ReadP Char
char Char
'['
  skipSpaces
  values <- sepBy parseJsonValue (skipSpaces >> char ',' >> skipSpaces)
  skipSpaces
  _ <- char ']'
  return $ JsonArray values

parseJsonString :: ReadP String
parseJsonString :: ReadP String
parseJsonString = do
  _ <- Char -> ReadP Char
char Char
'"'
  chars <- many parseJsonStringChar
  _ <- char '"'
  return chars

parseJsonStringChar :: ReadP Char
parseJsonStringChar :: ReadP Char
parseJsonStringChar =
  ReadP Char
parseEscaped ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP Char
parseUnescaped
  where
    parseEscaped :: ReadP Char
parseEscaped = do
      _ <- Char -> ReadP Char
char Char
'\\'
      choice
        [ '"' <$ char '"'
        , '\\' <$ char '\\'
        , '\n' <$ char 'n'
        , '\r' <$ char 'r'
        , '\t' <$ char 't'
        ]
    parseUnescaped :: ReadP Char
parseUnescaped = (Char -> Bool) -> ReadP Char
satisfy (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\')

parseJsonNumber :: ReadP JsonValue
parseJsonNumber :: ReadP JsonValue
parseJsonNumber = do
  sign <- (Char -> Bool) -> ReadP String
munch (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')
  digits <- munch isDigit
  if null digits || length sign > 1
    then fail "Invalid number"
    else return $ JsonNumber (read (sign ++ digits))

getRequired :: String -> [(String, JsonValue)] -> Either String JsonValue
getRequired :: String -> [(String, JsonValue)] -> Either String JsonValue
getRequired String
key [(String, JsonValue)]
objectFields =
  case String -> [(String, JsonValue)] -> Maybe JsonValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
key [(String, JsonValue)]
objectFields of
    Maybe JsonValue
Nothing -> String -> Either String JsonValue
forall a b. a -> Either a b
Left (String -> Either String JsonValue)
-> String -> Either String JsonValue
forall a b. (a -> b) -> a -> b
$ String
"Missing key: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
key
    Just JsonValue
value -> JsonValue -> Either String JsonValue
forall a b. b -> Either a b
Right JsonValue
value

getRequiredString :: String -> [(String, JsonValue)] -> Either String String
getRequiredString :: String -> [(String, JsonValue)] -> Either String String
getRequiredString String
key [(String, JsonValue)]
fields = do
  value <- String -> [(String, JsonValue)] -> Either String JsonValue
getRequired String
key [(String, JsonValue)]
fields
  asString key value

getRequiredNumber :: String -> [(String, JsonValue)] -> Either String Int
getRequiredNumber :: String -> [(String, JsonValue)] -> Either String Int
getRequiredNumber String
key [(String, JsonValue)]
fields = do
  value <- String -> [(String, JsonValue)] -> Either String JsonValue
getRequired String
key [(String, JsonValue)]
fields
  asNumber key value

asObject :: String -> JsonValue -> Either String [(String, JsonValue)]
asObject :: String -> JsonValue -> Either String [(String, JsonValue)]
asObject String
label JsonValue
value =
  case JsonValue
value of
    JsonObject [(String, JsonValue)]
fields -> [(String, JsonValue)] -> Either String [(String, JsonValue)]
forall a b. b -> Either a b
Right [(String, JsonValue)]
fields
    JsonValue
_ -> String -> Either String [(String, JsonValue)]
forall a b. a -> Either a b
Left (String -> Either String [(String, JsonValue)])
-> String -> Either String [(String, JsonValue)]
forall a b. (a -> b) -> a -> b
$ String
"Expected object for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
label

asArray :: String -> JsonValue -> Either String [JsonValue]
asArray :: String -> JsonValue -> Either String [JsonValue]
asArray String
label JsonValue
value =
  case JsonValue
value of
    JsonArray [JsonValue]
values -> [JsonValue] -> Either String [JsonValue]
forall a b. b -> Either a b
Right [JsonValue]
values
    JsonValue
_ -> String -> Either String [JsonValue]
forall a b. a -> Either a b
Left (String -> Either String [JsonValue])
-> String -> Either String [JsonValue]
forall a b. (a -> b) -> a -> b
$ String
"Expected array for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
label

asString :: String -> JsonValue -> Either String String
asString :: String -> JsonValue -> Either String String
asString String
label JsonValue
value =
  case JsonValue
value of
    JsonString String
str -> String -> Either String String
forall a b. b -> Either a b
Right String
str
    JsonValue
_ -> String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ String
"Expected string for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
label

asNumber :: String -> JsonValue -> Either String Int
asNumber :: String -> JsonValue -> Either String Int
asNumber String
label JsonValue
value =
  case JsonValue
value of
    JsonNumber Int
number -> Int -> Either String Int
forall a b. b -> Either a b
Right Int
number
    JsonValue
_ -> String -> Either String Int
forall a b. a -> Either a b
Left (String -> Either String Int) -> String -> Either String Int
forall a b. (a -> b) -> a -> b
$ String
"Expected number for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
label