module HEyefi.Config where import HEyefi.Log (logInfo) import HEyefi.Prelude import HEyefi.Types ( Config(..) , CardConfig , SharedConfig , LogLevel(Info) , cardMap , uploadDirectory , logLevel , HEyefiM(..)) 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 (modify, get, 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) import qualified Data.Text as T insertCard :: Text -> Text -> Config -> Config insertCard macAddress uploadKey c = 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 Text [(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 -> case convertCardList l of Left msg -> do logInfo msg return HM.empty Right cardList -> return (HM.fromList cardList) convertUploadDirectory :: Value -> Either Text FilePath convertUploadDirectory (CT.String uploadDir) = Right (T.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 -> case convertUploadDirectory uD of Left msg -> do logInfo msg return "" Right path -> return path reloadConfig :: FilePath -> HEyefiM Config reloadConfig configPath = do logInfo (tryingToLoadConfiguration (T.pack configPath)) catches ( do config <- liftIO (load [Required configPath]) configMap <- liftIO (getMap config) cardConfig <- getCardConfig configMap uploadDir <- getUploadDirectory configMap logInfo loadedConfiguration return Config { cardMap = cardConfig, uploadDirectory = uploadDir, logLevel = Info, lastSNonce = "" } -- TODO: Careful, we might be erasing something here. ) [Handler (\(ParseError p msg) -> do logInfo (errorParsingConfigurationFile (T.pack p) (T.pack msg)) return emptyConfig), Handler (\(SomeException _) -> do logInfo (couldNotFindConfigurationFile (T.pack 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 :: Text -> HEyefiM (Maybe Text) getUploadKeyForMacaddress mac = do c <- get return (HM.lookup mac (cardMap c)) putSNonce :: Text -> HEyefiM () putSNonce snonce = modify (\ s -> s { lastSNonce = snonce })