Config.hs

{-# LANGUAGE OverloadedStrings #-}

module HEyefi.Config where

import           HEyefi.Types (Config(..), CardConfig, SharedConfig, LogLevel(Info), cardMap, uploadDirectory, logLevel, HEyefiM(..))
import           HEyefi.Log (logInfo)
import           HEyefi.Constant hiding (configPath)

import           Control.Concurrent.STM (TVar, readTVar, newTVar, writeTVar, atomically, retry)
import           Control.Monad.Catch (finally, catches, Handler (..), SomeException (..))
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.State.Lazy (get, put, runStateT)
import           Data.Configurator (load, Worth (Required), getMap)
import           Data.Configurator.Types (Value, ConfigError (ParseError))
import qualified Data.Configurator.Types as CT
import           Data.HashMap.Strict ()
import qualified Data.HashMap.Strict as HM
import           Data.Maybe (mapMaybe)
import           Data.Text (Text, unpack, pack)

insertCard :: Text -> Text -> Config -> Config
insertCard macAddress uploadKey c = do
  Config {
    cardMap = HM.insert macAddress uploadKey (cardMap c),
    uploadDirectory = uploadDirectory c,
    logLevel = logLevel c,
    lastSNonce = lastSNonce c
    }


waitForWake :: TVar (Maybe Int) -> HEyefiM ()
waitForWake wakeSig = liftIO (atomically (
  do state <- readTVar wakeSig
     case state of
      Just _ -> writeTVar wakeSig Nothing
      Nothing -> retry))

convertCardList :: Value -> Either String [(Text, Text)]
convertCardList (CT.List innerList) =
  Right (mapMaybe extractTuple innerList)
  where
    extractTuple :: Value -> Maybe (Text, Text)
    extractTuple (CT.List [CT.String macAddress, CT.String key]) =
      Just (macAddress, key)
    extractTuple _ = Nothing
convertCardList _ = Left cardsFormatDoesNotMatch

getCardConfig :: HM.HashMap CT.Name CT.Value -> HEyefiM CardConfig
getCardConfig configMap = do
  let cards = HM.lookup "cards" configMap
  case cards of
   Nothing -> do
     logInfo missingCardsDefinition
     return HM.empty
   Just l -> do
     case convertCardList l of
      Left msg -> do
        logInfo msg
        return HM.empty
      Right cardList ->
        return (HM.fromList cardList)

convertUploadDirectory :: Value -> Either String FilePath
convertUploadDirectory (CT.String uploadDir) =
  Right (unpack uploadDir)
convertUploadDirectory _ =
  Left uploadDirFormatDoesNotMatch

getUploadDirectory :: HM.HashMap CT.Name CT.Value -> HEyefiM FilePath
getUploadDirectory configMap = do
  let uploadDir = HM.lookup "upload_dir" configMap
  case uploadDir of
   Nothing -> do
     logInfo missingUploadDirDefinition
     return ""
   Just uD -> do
     case convertUploadDirectory uD of
      Left msg -> do
        logInfo msg
        return ""
      Right path ->
        return path

reloadConfig :: FilePath -> HEyefiM Config
reloadConfig configPath = do
  logInfo ("Trying to load configuration at " ++ configPath)
  catches (
    do
      config <- liftIO (load [Required configPath])
      configMap <- liftIO (getMap config)
      cardConfig <- getCardConfig configMap
      uploadDir <- getUploadDirectory configMap
      logInfo "Loaded configuration"
      return Config {
        cardMap = cardConfig,
        uploadDirectory = uploadDir,
        logLevel = Info,
        lastSNonce = "" } -- TODO: Careful, we might be erasing something here.
    )
    [Handler (\(ParseError p msg) -> do
                 logInfo
                   ("Error parsing configuration file at " ++
                          p ++
                          " with message: " ++
                          msg)
                 return emptyConfig),
     Handler (\(SomeException _) -> do
                 logInfo
                   ("Could not find configuration file at " ++ configPath)
                 return emptyConfig)]

runWithConfig :: Config -> HEyefiM a -> IO (a,Config)
runWithConfig c m = runStateT (runHeyefi m) c

runWithEmptyConfig :: HEyefiM a -> IO (a,Config)
runWithEmptyConfig = runWithConfig emptyConfig

emptyConfig :: Config
emptyConfig = Config { cardMap = HM.empty
                     , uploadDirectory = ""
                     , logLevel = Info
                     , lastSNonce = ""}

newConfig :: IO SharedConfig
newConfig = atomically (newTVar emptyConfig)

-- Example config:
-- cards = [["0012342de4ce","e7403a0123402ca062"],["1234562d5678","12342a062"]]
-- upload_dir = "/data/annex/doxie/unsorted"
monitorConfig :: FilePath -> SharedConfig -> TVar (Maybe Int) -> HEyefiM ()
monitorConfig configPath sharedConfig wakeSignal =
  finally
    (do
        config <- reloadConfig configPath
        liftIO (atomically (writeTVar sharedConfig config)))
    (waitForWake wakeSignal)

getUploadKeyForMacaddress :: String -> HEyefiM (Maybe String)
getUploadKeyForMacaddress mac = do
  c <- get
  return (fmap unpack (HM.lookup (pack mac) (cardMap c)))

putSNonce :: String -> HEyefiM ()
putSNonce snonce = do
  c <- get
  put (Config {
          cardMap = cardMap c,
          uploadDirectory = uploadDirectory c,
          logLevel = logLevel c,
          lastSNonce = snonce
          })