HakunaStack.hs

{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
module HakunaStack where


import           Control.Lens
import           Control.Monad.Base
import           Control.Monad.Reader
import           Control.Monad.Trans.Control
import           Control.Monad.Trans.Either
import           CsvHelper
import qualified Data.ByteString.Lazy        as BS
import           Data.IntMap.Strict          as IM
import qualified Data.Map                    as Map
import           Data.Maybe                  (fromJust, fromMaybe)
import           Data.Monoid
import qualified Data.Text                   as T
import           Data.Time.Clock.POSIX       (getPOSIXTime)
import           Depot
import           Errors
import           Filesystem.Path.CurrentOS   as FP
import           Market
import           Person
import           Region
import           S3Uploader
import           Sign
import           System.FilePath.Glob
import           Zone

type Uploader = String -> BS.ByteString -> IO String

data ZenithEnv = ZenithEnv {
  _envDataRoot :: FP.FilePath,
  _envPeople   :: IntMap Person,
  _envDepots   :: IM.IntMap Depot,
  _envZones    :: IM.IntMap Zone,
  _envRegions  :: [Region],
  _envMarket   :: Market,
  _envUploader :: Uploader
}
makeLenses ''ZenithEnv

data Env = Env {
  _envByZenith :: Map.Map ZenithDataId ZenithEnv
}
makeLenses ''Env

envLookup :: Hakuna (ZenithDataId -> ZenithEnv)
envLookup = fmap (unsafeZenithLookup) (view envByZenith)

unsafeZenithLookup :: Map.Map ZenithDataId ZenithEnv -> ZenithDataId -> ZenithEnv
unsafeZenithLookup m z = fromMaybe (error $ "Unknown Zenith Data Set: " <> show z) $ Map.lookup z m

envDepotLookup :: Hakuna (ZenithDataId -> Int -> Depot)
envDepotLookup = foo <$> envLookup
  where foo zEnvLookup z i = unsafeLookupDepot (_envDepots $ zEnvLookup z) i

unsafeLookupDepot :: IntMap a -> Key -> a
unsafeLookupDepot m k = fromMaybe (error $ "Unknown depot id: " <> show k) $ IM.lookup k m

lookupDepot :: ZenithDataId -> Int -> Hakuna Depot
lookupDepot z n = envDepotLookup <*> pure z <*> pure n

newtype Hakuna a = Hakuna { runHakuna' :: ReaderT Env IO a }
    deriving (Monad, Functor, Applicative, MonadReader Env, MonadIO)

-- These instances are needed for Logging

instance MonadBase IO Hakuna where
  liftBase = liftIO

instance MonadBaseControl IO Hakuna where
    type StM Hakuna a   = a
    liftBaseWith f = Hakuna $ liftBaseWith (\q -> f (q . runHakuna'))
    restoreM       = Hakuna . restoreM

runHakuna :: Hakuna a -> Env -> IO a
runHakuna = runReaderT . runHakuna'

buildEnv' :: MonadIO m => FP.FilePath -> Market -> Bool -> m (Either StartupError Env)
buildEnv' base market doUpload = runEitherT $ do
  --zenithDataSets <- getZenithDataReleases base
  --bak <- fmap (fmap ffd) zenithDataSets
  --right $ (Env . Map.fromList) $ bak
  -- Env (Map.fromList blah)
  -- return $ blah
  return $ Env . Map.fromList <$> ffd z base market doUpload
  where z = ZenithDataId "Zenith2016"

ffd :: MonadIO m => ZenithDataId -> FP.FilePath -> Market -> Bool ->
                    m (Either StartupError (ZenithDataId, ZenithEnv))
ffd zId@(ZenithDataId zid) base market doUpload = do
  zEnv <- buildEnv (base </> FP.decodeString zid) market doUpload
  return $ (zId, zEnv)

getZenithDataReleases :: MonadIO m => FP.FilePath -> m (Either StartupError [ZenithDataId])
getZenithDataReleases base = do
  dirs <- globDir1 (compile "*") (FP.encodeString base)
  return $ (ZenithDataId . FP.decodeString) <$> dirs

buildEnv :: MonadIO m
         => FP.FilePath
         -> Market
         -> Bool
         -> m (Either StartupError ZenithEnv)
buildEnv base market doUpload = runEitherT $ do
  let peopledir   = base </> "tempest_inputs" </> "people"
      zonesfile   = base </> "tempest_inputs" </> "regions" </> "zones.csv"
      regionsfile = base </> "tempest_inputs" </> "regions" </> "regions.csv"
      depotsfile  = base </> "tempest_inputs" </> "depots"  </> "depots.csv"

  -- Loading people
  unzonedPeople <- liftIO $ personMap peopledir -- use faster, dodgier parser
  zones <- csvMap zonesfile ZoneParseError _zoneId
  let people = fmap (fmap (zones IM.!)) unzonedPeople

  regions <- liftIO $ regionFileProducer regionsfile
  depots  <- csvMap depotsfile DepotParseError _depotId

  uploader <- liftIO makeUploader
  let uppy tag kmz = do
        time <- (round <$> getPOSIXTime) :: IO Integer
        let bucket = "move-maps"
            mapFile = "hakuna_map_" <> T.pack (marketTag market) <> "_" <> T.pack tag <> "_" <> (T.pack . show $ time) <> ".kmz"
            thing = S3Location bucket mapFile
        upload uploader thing kmz
        return $ locationUrl thing

  return $ Env base people depots zones regions market $ if doUpload then uppy else (\_ _ -> return "http://example.com")