module Keter.Types.Common
( module Keter.Types.Common
, FilePath
, Text
, ByteString
, Set
, Map
, Exception
, SomeException
) where
import Control.Exception (Exception, SomeException)
import Data.Aeson (Object)
import Data.ByteString (ByteString)
import Data.Map (Map)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text, pack, unpack)
import Data.Typeable (Typeable)
import qualified Data.Yaml
import Filesystem.Path.CurrentOS (FilePath, basename, encodeString,
toText)
import qualified Language.Haskell.TH.Syntax as TH
import Prelude hiding (FilePath)
import System.Exit (ExitCode)
type Appname = Text
data Plugin = Plugin
{ pluginGetEnv :: Appname -> Object -> IO [(Text, Text)]
}
type Plugins = [Plugin]
class ToCurrent a where
type Previous a
toCurrent :: Previous a -> a
instance ToCurrent a => ToCurrent (Maybe a) where
type Previous (Maybe a) = Maybe (Previous a)
toCurrent = fmap toCurrent
type Port = Int
type Host = Text
type HostBS = ByteString
getAppname :: FilePath -> Text
getAppname = either id id . toText . basename
data LogMessage
= ProcessCreated FilePath
| InvalidBundle FilePath SomeException
| ProcessDidNotStart FilePath
| ExceptionThrown Text SomeException
| RemovingPort Int
| UnpackingBundle FilePath
| TerminatingApp Text
| FinishedReloading Text
| TerminatingOldProcess AppId
| RemovingOldFolder FilePath
| ReceivedInotifyEvent Text
| ProcessWaiting FilePath
| OtherMessage Text
| ErrorStartingBundle Text SomeException
| SanityChecksPassed
| ReservingHosts AppId (Set Host)
| ForgetingReservations AppId (Set Host)
| ActivatingApp AppId (Set Host)
| DeactivatingApp AppId (Set Host)
| ReactivatingApp AppId (Set Host) (Set Host)
| WatchedFile Text FilePath
instance Show LogMessage where
show (ProcessCreated f) = "Created process: " ++ encodeString f
show (InvalidBundle f e) = concat
[ "Unable to parse bundle file '"
, encodeString f
, "': "
, show e
]
show (ProcessDidNotStart fp) = concat
[ "Could not start process within timeout period: "
, encodeString fp
]
show (ExceptionThrown t e) = concat
[ unpack t
, ": "
, show e
]
show (RemovingPort p) = "Port in use, removing from port pool: " ++ show p
show (UnpackingBundle b) = concat
[ "Unpacking bundle '"
, encodeString b
, "'"
]
show (TerminatingApp t) = "Shutting down app: " ++ unpack t
show (FinishedReloading t) = "App finished reloading: " ++ unpack t
show (TerminatingOldProcess (AINamed t)) = "Sending old process TERM signal: " ++ unpack t
show (TerminatingOldProcess AIBuiltin) = "Sending old process TERM signal: builtin"
show (RemovingOldFolder fp) = "Removing unneeded folder: " ++ encodeString fp
show (ReceivedInotifyEvent t) = "Received unknown INotify event: " ++ unpack t
show (ProcessWaiting f) = "Process restarting too quickly, waiting before trying again: " ++ encodeString f
show (OtherMessage t) = unpack t
show (ErrorStartingBundle name e) = concat
[ "Error occured when launching bundle "
, unpack name
, ": "
, show e
]
show SanityChecksPassed = "Sanity checks passed"
show (ReservingHosts app hosts) = "Reserving hosts for app " ++ show app ++ ": " ++ unwords (map unpack $ Set.toList hosts)
show (ForgetingReservations app hosts) = "Forgeting host reservations for app " ++ show app ++ ": " ++ unwords (map unpack $ Set.toList hosts)
show (ActivatingApp app hosts) = "Activating app " ++ show app ++ " with hosts: " ++ unwords (map unpack $ Set.toList hosts)
show (DeactivatingApp app hosts) = "Deactivating app " ++ show app ++ " with hosts: " ++ unwords (map unpack $ Set.toList hosts)
show (ReactivatingApp app old new) = concat
[ "Reactivating app "
, show app
, ". Old hosts: "
, unwords (map unpack $ Set.toList old)
, ". New hosts: "
, unwords (map unpack $ Set.toList new)
, "."
]
show (WatchedFile action fp) = concat
[ "Watched file "
, unpack action
, ": "
, encodeString fp
]
data KeterException = CannotParsePostgres FilePath
| ExitCodeFailure FilePath ExitCode
| NoPortsAvailable
| InvalidConfigFile Data.Yaml.ParseException
| InvalidKeterConfigFile !FilePath !Data.Yaml.ParseException
| CannotReserveHosts !AppId !(Map Host AppId)
| FileNotExecutable !FilePath
| ExecutableNotFound !FilePath
deriving (Show, Typeable)
instance Exception KeterException
logEx :: TH.Q TH.Exp
logEx = do
let showLoc TH.Loc { TH.loc_module = m, TH.loc_start = (l, c) } = concat
[ m
, ":"
, show l
, ":"
, show c
]
loc <- fmap showLoc TH.qLocation
[|(. ExceptionThrown (pack $(TH.lift loc)))|]
data AppId = AIBuiltin | AINamed !Appname
deriving (Eq, Ord)
instance Show AppId where
show AIBuiltin = "/builtin/"
show (AINamed t) = unpack t