snoyberg/keter
1
1
Fork 0
mirror of https://github.com/snoyberg/keter.git synced 2024-12-13 19:28:17 +03:00
Code Issues Projects Releases Wiki Activity

Removed Keter.Prelude

Browse Source
This commit is contained in:
Michael Snoyman 2013-07-28 13:41:42 +03:00
parent d09f91e071
commit 5c368043c8
12 changed files with 238 additions and 499 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
Keter/App.hs
View File

@ -1,6 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
module Keter.App
@ -16,8 +15,6 @@ module Keter.App
import System.Posix.Types (EpochTime)
import Control.Concurrent.STM (STM)
import Prelude (IO, Eq, Ord, fst, snd, concat, mapM)
import Keter.Prelude
import Codec.Archive.TempTarball
import Keter.Types
import Keter.HostManager hiding (start)
@ -27,7 +24,7 @@ import Data.Yaml
import Control.Applicative ((<$>))
import qualified Network
import Data.Maybe (fromMaybe)
import Control.Exception (throwIO)
import Control.Exception (throwIO, try, IOException)
import System.IO (hClose)
import qualified Data.Set as Set
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
@ -35,20 +32,23 @@ import Data.Text.Encoding.Error (lenientDecode)
import System.Posix.Types (UserID, GroupID)
import Data.Conduit.Process.Unix (ProcessTracker, RotatingLog, terminateMonitoredProcess, monitorProcess)
import Data.Yaml.FilePath
import qualified Prelude
import Keter.PortPool (PortPool)
import Control.Concurrent (threadDelay)
import System.Timeout (timeout)
import Prelude hiding (FilePath)
data Command = Reload | Terminate
newtype App = App (Command -> KIO ())
newtype App = App (Command -> IO ())
unpackBundle :: TempFolder
unpackBundle :: (LogMessage -> IO ())
-> TempFolder
-> Maybe (UserID, GroupID)
-> F.FilePath
-> FilePath
-> Appname
-> KIO (Either SomeException (FilePath, BundleConfig))
unpackBundle tf muid bundle appname = do
-> IO (FilePath, BundleConfig)
unpackBundle log tf muid bundle appname = do
log $ UnpackingBundle bundle
liftIO $ unpackTempTar muid tf bundle appname $ \dir -> do
unpackTempTar muid tf bundle appname $ \dir -> do
let configFP = dir F.</> "config" F.</> "keter.yaml"
mconfig <- decodeFileRelative configFP
config <-
@ -75,8 +75,8 @@ data AppId = AIBuiltin | AINamed !Appname
start :: AppStartConfig
-> AppId
-> AppInput -- ^ if not provided, we'll extract from the relevant file
-> KIO (Either SomeException App)
start _ _ _ = liftIO $ Prelude.error "Keter.App.start"
-> IO App
start _ _ _ = error "Keter.App.start"
{-
start :: TempFolder
@ -225,27 +225,24 @@ start tf muid processTracker portman plugins rlog appname bundle removeFromList
Right () -> return ()
-}
testApp :: Port -> KIO Bool
testApp :: Port -> IO Bool
testApp port = do
res <- timeout (90 * 1000 * 1000) testApp'
return $ fromMaybe False res
where
testApp' = do
threadDelay $ 2 * 1000 * 1000
eres <- liftIO $ Network.connectTo "127.0.0.1" $ Network.PortNumber $ fromIntegral port
eres <- try $ Network.connectTo "127.0.0.1" $ Network.PortNumber $ fromIntegral port
case eres of
Left _ -> testApp'
Left (_ :: IOException) -> testApp'
Right handle -> do
res <- liftIO $ hClose handle
case res of
Left e -> $logEx e
Right () -> return ()
hClose handle
return True
reload :: App -> AppInput -> KIO ()
reload :: App -> AppInput -> IO ()
reload (App f) _fixme = f Reload
terminate :: App -> KIO ()
terminate :: App -> IO ()
terminate (App f) = f Terminate
-- | Get the modification time of the bundle file this app was launched from,
@ -253,8 +250,8 @@ terminate (App f) = f Terminate
getTimestamp :: App -> STM (Maybe EpochTime)
getTimestamp _ = return Nothing -- FIXME
pluginsGetEnv :: Plugins -> Appname -> Object -> KIO (Either SomeException [(Text, Text)])
pluginsGetEnv ps app o = liftIO $ fmap concat $ mapM (\p -> pluginGetEnv p app o) ps
pluginsGetEnv :: Plugins -> Appname -> Object -> IO (Either SomeException [(Text, Text)])
pluginsGetEnv ps app o = try $ fmap concat $ mapM (\p -> pluginGetEnv p app o) ps
{- FIXME handle static stanzas
let staticReverse r = do

64
Keter/AppManager.hs
View File

@ -8,7 +8,6 @@ module Keter.AppManager
, AppId (..)
, Action (..)
, AppInput (..)
, RunKIO (..)
-- * Actions
, perform
, reloadAppList
@ -19,32 +18,29 @@ module Keter.AppManager
) where
import Control.Applicative
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
import Control.Concurrent.STM
import qualified Control.Exception as E
import Control.Monad (void)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Data.Maybe (catMaybes)
import Data.Set (Set)
import qualified Data.Set as Set
import System.Posix.Types (EpochTime)
import Keter.App (App, AppId (..), AppInput (..),
AppStartConfig)
import qualified Keter.App as App
import Keter.Prelude (KIO, getAppname)
import qualified Keter.Prelude as KP
import Keter.Types
import System.Posix.Files (modificationTime, getFileStatus)
import qualified Control.Exception as E
import Control.Monad (void)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Data.Maybe (catMaybes)
import qualified Data.Set as Set
import qualified Filesystem.Path.CurrentOS as F
import Keter.App (App, AppId (..), AppInput (..),
AppStartConfig)
import qualified Keter.App as App
import Keter.Types
import Prelude hiding (FilePath, log)
import System.Posix.Files (getFileStatus, modificationTime)
import System.Posix.Types (EpochTime)
data AppManager = AppManager
{ apps :: !(TVar (Map AppId (TVar AppState)))
, runKIO :: !RunKIO
, appStartConfig :: !AppStartConfig
, mutex :: !(MVar ())
, log :: !(LogMessage -> IO ())
}
data AppState = ASRunning App
@ -56,14 +52,14 @@ data AppState = ASRunning App
data Action = Reload AppInput | Terminate
newtype RunKIO = RunKIO { unRunKIO :: forall a. KIO a -> IO a }
initialize :: RunKIO -> AppStartConfig -> IO AppManager
initialize runKIO' asc = AppManager
initialize :: (LogMessage -> IO ())
-> AppStartConfig
-> IO AppManager
initialize log' asc = AppManager
<$> newTVarIO Map.empty
<*> return runKIO'
<*> return asc
<*> newMVar ()
<*> return log'
-- | Reset which apps are running.
--
@ -73,7 +69,7 @@ initialize runKIO' asc = AppManager
--
-- * Any app listed here that is not currently running will be started.
reloadAppList :: AppManager
-> Map Appname (KP.FilePath, EpochTime)
-> Map Appname (FilePath, EpochTime)
-> IO ()
reloadAppList am@AppManager {..} newApps = withMVar mutex $ const $ do
actions <- atomically $ do
@ -219,36 +215,38 @@ launchWorker AppManager {..} appid tstate tmnext mcurrentApp0 action0 = void $ f
return mnext
case mnext of
Nothing -> return ()
Just next -> loop mRunningApp action
Just next -> loop mRunningApp next
processAction Nothing Terminate = return Nothing
processAction (Just app) Terminate = do
unRunKIO runKIO $ App.terminate app
App.terminate app
return Nothing
processAction Nothing (Reload input) = unRunKIO runKIO $ do
eres <- App.start appStartConfig appid input
processAction Nothing (Reload input) = do
eres <- E.try $ App.start appStartConfig appid input
case eres of
Left e -> do
let name =
case appid of
AIBuiltin -> "<builtin>"
AINamed x -> x
KP.log $ KP.ErrorStartingBundle name e
log $ ErrorStartingBundle name e
return Nothing
Right app -> return $ Just app
processAction (Just app) (Reload input) = unRunKIO runKIO $ do
processAction (Just app) (Reload input) = do
App.reload app input
-- reloading will /always/ result in a valid app, either the old one
-- will continue running or the new one will replace it.
return $ Just app
addApp :: AppManager -> FilePath -> IO ()
addApp appMan bundle = do
(input, action) <- getInputForBundle bundle
etime <- modificationTime <$> getFileStatus (F.encodeString bundle)
perform appMan input action
getInputForBundle :: FilePath -> IO (AppId, Action)
getInputForBundle bundle = do
time <- modificationTime <$> getFileStatus (F.encodeString bundle)
return (AINamed $ getAppname bundle, Reload $ AIBundle bundle time)
terminateApp :: AppManager -> Appname -> IO ()
terminateApp appMan appname = perform appMan (AINamed appname) Terminate

32
Keter/HostManager.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
@ -18,30 +17,26 @@ module Keter.HostManager
) where
import Control.Applicative
import qualified Control.Concurrent.MVar as M
import Control.Exception (assert)
import Data.ByteString.Char8 ()
import Data.Either (partitionEithers)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Text.Encoding (encodeUtf8)
import Keter.Prelude
import Keter.Types
import Prelude (null)
import Prelude (IO)
import Data.IORef
type HMState = Map.Map HostBS HostValue
data HostValue = HVActive !Appname !ProxyAction
| HVReserved !Appname
newtype HostManager = HostManager (MVar HMState) -- FIXME use an IORef instead
newtype HostManager = HostManager (IORef HMState)
type Conflicts = Map.Map Host Appname
type Reservations = Set.Set Host
start :: IO HostManager
start = HostManager <$> M.newMVar Map.empty
start = HostManager <$> newIORef Map.empty
-- | Reserve the given hosts so that no other application may use them. Does
-- not yet enable any action. The semantics are:
@ -61,9 +56,9 @@ start = HostManager <$> M.newMVar Map.empty
reserveHosts :: HostManager
-> Appname
-> Set.Set Host
-> KIO (Either Conflicts Reservations)
reserveHosts (HostManager mstate) app hosts = modifyMVar mstate $ \entries0 ->
return $ case partitionEithers $ map (checkHost entries0) $ Set.toList hosts of
-> IO (Either Conflicts Reservations)
reserveHosts (HostManager mstate) app hosts = atomicModifyIORef mstate $ \entries0 ->
case partitionEithers $ map (checkHost entries0) $ Set.toList hosts of
([], toReserve) ->
(Set.foldr reserve entries0 $ Set.unions toReserve, Right Set.empty)
(conflicts, _) -> (entries0, Left $ Map.fromList conflicts)
@ -87,9 +82,9 @@ reserveHosts (HostManager mstate) app hosts = modifyMVar mstate $ \entries0 ->
forgetReservations :: HostManager
-> Appname
-> Reservations
-> KIO ()
forgetReservations (HostManager mstate) app hosts = modifyMVar_ mstate $ \state0 ->
return $ Set.foldr forget state0 hosts
-> IO ()
forgetReservations (HostManager mstate) app hosts = atomicModifyIORef mstate $ \state0 ->
(Set.foldr forget state0 hosts, ())
where
forget host state =
assert isReservedByMe $ Map.delete hostBS state
@ -105,9 +100,9 @@ forgetReservations (HostManager mstate) app hosts = modifyMVar_ mstate $ \state0
activateApp :: HostManager
-> Appname
-> Map.Map Host ProxyAction
-> KIO ()
activateApp (HostManager mstate) app actions = modifyMVar_ mstate $ \state0 ->
return $ Map.foldrWithKey activate state0 actions
-> IO ()
activateApp (HostManager mstate) app actions = atomicModifyIORef mstate $ \state0 ->
(Map.foldrWithKey activate state0 actions, ())
where
activate host action state =
assert isOwnedByMe $ Map.insert hostBS (HVActive app action) state
@ -122,7 +117,8 @@ activateApp (HostManager mstate) app actions = modifyMVar_ mstate $ \state0 ->
lookupAction :: HostManager
-> HostBS
-> IO (Maybe ProxyAction)
lookupAction (HostManager mstate) host = M.withMVar mstate $ \state ->
lookupAction (HostManager mstate) host = do
state <- readIORef mstate
return $ case Map.lookup host state of
Nothing -> Nothing
Just (HVActive _ action) -> Just action

57
Keter/Main.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
@ -19,7 +18,6 @@ import Keter.App (AppStartConfig (..))
import qualified Keter.AppManager as AppMan
import qualified Keter.HostManager as HostMan
import qualified Keter.PortPool as PortPool
import Keter.Prelude hiding (getCurrentTime, runKIO)
import qualified Keter.Proxy as Proxy
import Keter.Types
import System.Posix.Files (getFileStatus, modificationTime)
@ -28,7 +26,6 @@ import System.Posix.Signals (Handler (Catch), installHandler,
import Control.Applicative ((<$>))
import Control.Exception (throwIO, try)
import Control.Exception (Exception)
import Control.Monad (forM)
import Data.Conduit.Process.Unix (initProcessTracker)
import qualified Data.Map as Map
@ -41,18 +38,20 @@ import Data.Yaml (ParseException)
import Data.Yaml.FilePath
import qualified Filesystem as F
import qualified Filesystem.Path.CurrentOS as F
import qualified Keter.Prelude
import Filesystem.Path.CurrentOS ((</>), hasExtension)
import qualified Network.HTTP.Conduit as HTTP (newManager)
import Prelude (IO)
import qualified Prelude as P
import qualified System.FSNotify as FSN
import System.Posix.User (getUserEntryForID,
getUserEntryForName, userGroupID,
userID, userName)
import Control.Monad (void, when)
import Data.Default (def)
import Prelude hiding (FilePath, log)
import Filesystem (listDirectory, createTree)
keter :: F.FilePath -- ^ root directory or config file
-> [F.FilePath -> P.IO Plugin]
-> P.IO ()
keter :: FilePath -- ^ root directory or config file
-> [FilePath -> IO Plugin]
-> IO ()
keter input mkPlugins = withManagers input mkPlugins $ \kc hostman appMan -> do
launchInitial kc appMan
startWatching kc appMan
@ -74,34 +73,34 @@ withConfig input f = do
else return def { kconfigDir = input }
f config
withRunner :: FilePath
-> (KeterConfig -> (forall a. KIO a -> IO a) -> IO b)
-> IO b
withRunner fp f = withConfig fp $ \config -> do
withLogger :: FilePath
-> (KeterConfig -> (LogMessage -> IO ()) -> IO a)
-> IO a
withLogger fp f = withConfig fp $ \config -> do
mainlog <- LogFile.openRotatingLog
(F.encodeString $ (kconfigDir config) </> "log" </> "keter")
LogFile.defaultMaxTotal
f config $ Keter.Prelude.runKIO $ \ml -> do
now <- getCurrentTime
let bs = encodeUtf8 $ T.concat
[ T.take 22 $ show now
, ": "
, show ml
, "\n"
]
LogFile.addChunk mainlog bs
f config $ \ml -> do
now <- getCurrentTime
let bs = encodeUtf8 $ T.pack $ concat
[ take 22 $ show now
, ": "
, show ml
, "\n"
]
LogFile.addChunk mainlog bs
withManagers :: FilePath
-> [FilePath -> IO Plugin]
-> (KeterConfig -> HostMan.HostManager -> AppMan.AppManager -> IO a)
-> IO a
withManagers input mkPlugins f = withRunner input $ \kc@KeterConfig {..} runKIO -> do
withManagers input mkPlugins f = withLogger input $ \kc@KeterConfig {..} log -> do
processTracker <- initProcessTracker
hostman <- HostMan.start
portpool <- PortPool.start kconfigPortPool
tf <- TempFolder.setup $ kconfigDir </> "temp"
plugins <- P.sequence $ map ($ kconfigDir) mkPlugins
plugins <- sequence $ map ($ kconfigDir) mkPlugins
muid <-
case kconfigSetuid of
Nothing -> return Nothing
@ -111,7 +110,7 @@ withManagers input mkPlugins f = withRunner input $ \kc@KeterConfig {..} runKIO
Right (i, "") -> getUserEntryForID i
_ -> getUserEntryForName $ T.unpack t
case x of
Left (_ :: SomeException) -> P.error $ T.unpack $ "Invalid user ID: " ++ t
Left (_ :: SomeException) -> error $ "Invalid user ID: " ++ T.unpack t
Right ue -> return $ Just (T.pack $ userName ue, (userID ue, userGroupID ue))
let appStartConfig = AppStartConfig
@ -122,7 +121,7 @@ withManagers input mkPlugins f = withRunner input $ \kc@KeterConfig {..} runKIO
, ascPortPool = portpool
, ascPlugins = plugins
}
appMan <- AppMan.initialize (AppMan.RunKIO runKIO) appStartConfig
appMan <- AppMan.initialize log appStartConfig
f kc hostman appMan
data InvalidKeterConfigFile = InvalidKeterConfigFile !FilePath !ParseException
@ -152,7 +151,7 @@ startWatching :: KeterConfig -> AppMan.AppManager -> IO ()
startWatching kc@KeterConfig {..} appMan = do
-- File system watching
wm <- FSN.startManager
FSN.watchDir wm incoming (P.const True) $ \e ->
FSN.watchDir wm incoming (const True) $ \e ->
let e' =
case e of
FSN.Removed fp _ -> Left fp
@ -181,8 +180,8 @@ startListening KeterConfig {..} hostman = do
(HostMan.lookupAction hostman)
runAndBlock :: NonEmptyVector a
-> (a -> P.IO ())
-> P.IO ()
-> (a -> IO ())
-> IO ()
runAndBlock (NonEmptyVector x0 v) f =
loop l0 []
where

6
Keter/Plugin/Postgres.hs
View File

@ -13,7 +13,7 @@ import Control.Applicative ((<$>), (<*>))
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan
import Control.Concurrent.MVar
import Control.Exception (SomeException, throwIO, try)
import Control.Exception (throwIO, try)
import Control.Monad (void)
import Control.Monad (forever, mzero, replicateM)
import Control.Monad.Trans.Class (lift)
@ -22,14 +22,12 @@ import Data.Default
import qualified Data.HashMap.Strict as HMap
import qualified Data.Map as Map
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (fromText, toLazyText)
import Data.Yaml
import Filesystem (createTree, isFile, rename)
import Filesystem.Path.CurrentOS (FilePath, directory, encodeString,
(<.>))
import Filesystem.Path.CurrentOS (directory, encodeString, (<.>))
import Keter.Types
import Prelude hiding (FilePath)
import System.Process (readProcess)

25
Keter/PortPool.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
@ -14,11 +13,11 @@ module Keter.PortPool
) where
import Control.Applicative ((<$>))
import qualified Control.Concurrent.MVar as M
import Keter.Prelude
import Control.Concurrent.MVar
import Control.Exception
import Keter.Types
import qualified Network
import Prelude (IO)
import Prelude hiding (log)
data PPState = PPState
{ ppAvail :: ![Port]
@ -28,25 +27,27 @@ data PPState = PPState
newtype PortPool = PortPool (MVar PPState)
-- | Gets an unassigned port number.
getPort :: PortPool -> KIO (Either SomeException Port)
getPort (PortPool mstate) =
getPort :: (LogMessage -> IO ())
-> PortPool
-> IO (Either SomeException Port)
getPort log (PortPool mstate) =
modifyMVar mstate loop
where
loop :: PPState -> KIO (PPState, Either SomeException Port)
loop :: PPState -> IO (PPState, Either SomeException Port)
loop PPState {..} =
case ppAvail of
p:ps -> do
let next = PPState ps ppRecycled
res <- liftIO $ Network.listenOn $ Network.PortNumber $ fromIntegral p
res <- try $ Network.listenOn $ Network.PortNumber $ fromIntegral p
case res of
Left (_ :: SomeException) -> do
log $ RemovingPort p
loop next
Right socket -> do
res' <- liftIO $ Network.sClose socket
res' <- try $ Network.sClose socket
case res' of
Left e -> do
$logEx e
$logEx log e
log $ RemovingPort p
loop next
Right () -> return (next, Right p)
@ -58,12 +59,12 @@ getPort (PortPool mstate) =
-- | Return a port to the recycled collection of the pool. Note that recycling
-- puts the new ports at the end of the queue (FIFO), so that if an application
-- holds onto the port longer than expected, there should be no issues.
releasePort :: PortPool -> Port -> KIO ()
releasePort :: PortPool -> Port -> IO ()
releasePort (PortPool mstate) p =
modifyMVar_ mstate $ \(PPState avail recycled) -> return $ PPState avail $ recycled . (p:)
start :: PortSettings -> IO PortPool
start PortSettings{..} =
PortPool <$> M.newMVar freshState
PortPool <$> newMVar freshState
where
freshState = PPState portRange id

346
Keter/Prelude.hs
View File

@ -1,346 +0,0 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
module Keter.Prelude
( T.Text
, String
, P.Monad (..)
, P.Maybe (..)
, P.Bool (..)
, (P.$)
, (P..)
, LogMessage (..)
, log
, logEx
, KIO
, toString
, P.map
, (A.***)
, readFileLBS
, P.Either (..)
, P.either
, E.SomeException
, runKIO
, void
, liftIO
, forkKIO
, forkKIO'
, getIOLogger
, (++)
, P.minBound
, P.succ
, show
, Control.Monad.when
, fromText
, P.flip
, P.Show
, KeterException (..)
, E.toException
, newStdGen
, Default (..)
, P.Int
, (P.&&)
, (P.==)
, (P./=)
, (P.*)
, P.fromIntegral
, P.reverse
, P.otherwise
, timeout
, threadDelay
, P.id
, P.filter
, P.mapM_
, P.fmap
, P.not
, P.maybe
, (P.>)
, (P.<)
, (P.<=)
, (P.+)
, (P.-)
, getCurrentTime
, getAppname
-- * Filepath
, (F.</>)
, (F.<.>)
, F.FilePath
, F.isDirectory
, F.isFile
, F.removeTree
, F.createTree
, F.directory
, F.rename
, F.basename
, F.toText
, F.hasExtension
, F.listDirectory
, F.decodeString
-- * MVar
, M.MVar
, newMVar
, newEmptyMVar
, modifyMVar
, modifyMVar_
, withMVar
, swapMVar
, takeMVar
, tryTakeMVar
, putMVar
-- * STM
, atomicallyK
-- * IORef
, I.IORef
, newIORef
, atomicModifyIORef
-- * Chan
, C.Chan
, newChan
, readChan
, writeChan
-- * Exception
, mask_
) where
import qualified Filesystem.Path.CurrentOS as F
import qualified Filesystem as F
import qualified Data.Text as T
import qualified Prelude as P
import qualified Control.Arrow as A
import qualified Data.ByteString.Lazy as L
import Prelude (($), (.))
import qualified Control.Exception as E
import qualified Control.Monad
import qualified Control.Applicative
import qualified Control.Concurrent.MVar as M
import Control.Concurrent (forkIO, ThreadId)
import qualified Control.Concurrent
import qualified Data.IORef as I
import Data.Monoid (Monoid, mappend)
import qualified Data.Text.Lazy.Builder as B
import Data.Typeable (Typeable)
import qualified Control.Concurrent.Chan as C
import Control.Concurrent.STM (STM, atomically)
import qualified System.Random as R
import Data.Default (Default (..))
import System.Exit (ExitCode)
import qualified Blaze.ByteString.Builder as Blaze
import qualified Blaze.ByteString.Builder.Char.Utf8
import qualified System.Timeout
import qualified Language.Haskell.TH.Syntax as TH
import qualified Data.Time
import qualified Data.Yaml
type String = T.Text
newtype KIO a = KIO { unKIO :: (LogMessage -> P.IO ()) -> P.IO a }
instance P.Monad KIO where
return = KIO . P.const . P.return
KIO x >>= y = KIO $ \f -> do
x' <- x f
let KIO mz = y x'
mz f
instance P.Functor KIO where
fmap = Control.Monad.liftM
instance Control.Applicative.Applicative KIO where
(<*>) = Control.Monad.ap
pure = P.return
log :: LogMessage -> KIO ()
log msg = do
f <- getLogger
void $ liftIO $ f msg
where
getLogger = KIO P.return
void :: P.Monad m => m a -> m ()
void f = f P.>> P.return ()
data LogMessage
= ProcessCreated F.FilePath
| InvalidBundle F.FilePath E.SomeException
| ProcessDidNotStart F.FilePath
| ExceptionThrown T.Text E.SomeException
| RemovingPort P.Int
| UnpackingBundle F.FilePath
| TerminatingApp T.Text
| FinishedReloading T.Text
| TerminatingOldProcess T.Text
| RemovingOldFolder F.FilePath
| ReceivedInotifyEvent T.Text
| ProcessWaiting F.FilePath
| OtherMessage T.Text
| ErrorStartingBundle T.Text E.SomeException
instance P.Show LogMessage where
show (ProcessCreated f) = "Created process: " ++ F.encodeString f
show (InvalidBundle f e) = P.concat
[ "Unable to parse bundle file '"
, F.encodeString f
, "': "
, P.show e
]
show (ProcessDidNotStart fp) = P.concat
[ "Could not start process within timeout period: "
, F.encodeString fp
]
show (ExceptionThrown t e) = P.concat
[ T.unpack t
, ": "
, P.show e
]
show (RemovingPort p) = "Port in use, removing from port pool: " ++ P.show p
show (UnpackingBundle b) = P.concat
[ "Unpacking bundle '"
, F.encodeString b
, "'"
]
show (TerminatingApp t) = "Shutting down app: " ++ T.unpack t
show (FinishedReloading t) = "App finished reloading: " ++ T.unpack t
show (TerminatingOldProcess t) = "Sending old process TERM signal: " ++ T.unpack t
show (RemovingOldFolder fp) = "Removing unneeded folder: " ++ F.encodeString fp
show (ReceivedInotifyEvent t) = "Received unknown INotify event: " ++ T.unpack t
show (ProcessWaiting f) = "Process restarting too quickly, waiting before trying again: " ++ F.encodeString f
show (OtherMessage t) = T.unpack t
show (ErrorStartingBundle name e) = P.concat
[ "Error occured when launching bundle "
, T.unpack name
, ": "
, P.show e
]
getIOLogger :: KIO (T.Text -> P.IO ())
getIOLogger = KIO $ \f -> P.return $ f . OtherMessage
logEx :: TH.Q TH.Exp
logEx = do
let showLoc TH.Loc { TH.loc_module = m, TH.loc_start = (l, c) } = P.concat
[ m
, ":"
, P.show l
, ":"
, P.show c
]
loc <- P.fmap showLoc TH.qLocation
[|log P.. ExceptionThrown (T.pack $(TH.lift loc))|]
class ToString a where
toString :: a -> P.String
instance ToString P.String where
toString = P.id
instance ToString T.Text where
toString = T.unpack
instance ToString F.FilePath where
toString = F.encodeString
readFileLBS :: F.FilePath -> KIO (P.Either E.SomeException L.ByteString)
readFileLBS = liftIO . L.readFile P.. toString
liftIO :: P.IO a -> KIO (P.Either E.SomeException a)
liftIO = KIO . P.const . E.try
liftIO_ :: P.IO a -> KIO a
liftIO_ = KIO . P.const
runKIO :: (LogMessage -> P.IO ()) -> KIO a -> P.IO a
runKIO f (KIO g) = g f
newMVar :: a -> KIO (M.MVar a)
newMVar = liftIO_ . M.newMVar
newEmptyMVar :: KIO (M.MVar a)
newEmptyMVar = liftIO_ M.newEmptyMVar
modifyMVar :: M.MVar a -> (a -> KIO (a, b)) -> KIO b
modifyMVar m f = KIO $ \x -> M.modifyMVar m (\a -> unKIO (f a) x)
withMVar :: M.MVar a -> (a -> KIO b) -> KIO b
withMVar m f = KIO $ \x -> M.withMVar m (\a -> unKIO (f a) x)
modifyMVar_ :: M.MVar a -> (a -> KIO a) -> KIO ()
modifyMVar_ m f = KIO $ \x -> M.modifyMVar_ m (\a -> unKIO (f a) x)
swapMVar :: M.MVar a -> a -> KIO a
swapMVar m = liftIO_ . M.swapMVar m
takeMVar :: M.MVar a -> KIO a
takeMVar = liftIO_ . M.takeMVar
tryTakeMVar :: M.MVar a -> KIO (P.Maybe a)
tryTakeMVar = liftIO_ . M.tryTakeMVar
putMVar :: M.MVar a -> a -> KIO ()
putMVar m = liftIO_ . M.putMVar m
atomicallyK :: STM a -> KIO a
atomicallyK = liftIO_ . atomically
forkKIO :: KIO () -> KIO ()
forkKIO = void . forkKIO'
forkKIO' :: KIO () -> KIO (P.Either E.SomeException ThreadId)
forkKIO' f = do
x <- KIO P.return
liftIO $ forkIO $ unKIO f x
newIORef :: a -> KIO (I.IORef a)
newIORef = liftIO_ . I.newIORef
atomicModifyIORef :: I.IORef a -> (a -> (a, b)) -> KIO b
atomicModifyIORef x = liftIO_ . I.atomicModifyIORef x
(++) :: Monoid m => m -> m -> m
(++) = mappend
show :: P.Show a => a -> T.Text
show = T.pack . P.show
class FromText a where
fromText :: T.Text -> a
instance FromText T.Text where
fromText = P.id
instance FromText F.FilePath where
fromText = F.fromText
instance FromText B.Builder where
fromText = B.fromText
instance FromText Blaze.Builder where
fromText = Blaze.ByteString.Builder.Char.Utf8.fromText
data KeterException = CannotParsePostgres F.FilePath
| ExitCodeFailure F.FilePath ExitCode
| NoPortsAvailable
| InvalidConfigFile Data.Yaml.ParseException
deriving (P.Show, Typeable)
instance E.Exception KeterException
newChan :: KIO (C.Chan a)
newChan = liftIO_ C.newChan
newStdGen :: KIO R.StdGen
newStdGen = liftIO_ R.newStdGen
readChan :: C.Chan a -> KIO a
readChan = liftIO_ . C.readChan
writeChan :: C.Chan a -> a -> KIO ()
writeChan c = liftIO_ . C.writeChan c
timeout :: P.Int -> KIO a -> KIO (P.Maybe a)
timeout seconds (KIO f) = KIO $ \x -> System.Timeout.timeout seconds $ f x
threadDelay :: P.Int -> KIO ()
threadDelay = liftIO_ . Control.Concurrent.threadDelay
getCurrentTime :: KIO Data.Time.UTCTime
getCurrentTime = liftIO_ Data.Time.getCurrentTime
mask_ :: KIO a -> KIO a
mask_ (KIO f) = KIO (\lm -> E.mask_ (f lm))
getAppname :: F.FilePath -> T.Text
getAppname = P.either P.id P.id . F.toText . F.basename

49
Keter/Proxy.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecordWildCards #-}
-- | A light-weight, minimalistic reverse HTTP proxy.
module Keter.Proxy
( reverseProxy
@ -7,27 +7,34 @@ module Keter.Proxy
, TLSConfig (..)
) where
import Prelude hiding ((++), FilePath)
import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Network.HTTP.ReverseProxy (waiProxyToSettings, wpsSetIpHeader, SetIpHeader (..), ProxyDest (ProxyDest), WaiProxyResponse (..))
import Network.Wai.Application.Static (defaultFileServerSettings, staticApp, ssListing)
import WaiAppStatic.Listing (defaultListing)
import qualified Network.Wai as Wai
import Network.HTTP.Types (status301, status302, status303, status307, status404, status200, mkStatus)
import Blaze.ByteString.Builder (copyByteString)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Default
import Data.Monoid (mappend)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Vector as V
import qualified Filesystem.Path.CurrentOS as F
import Keter.Types
import Network.HTTP.Conduit (Manager)
import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest),
SetIpHeader (..),
WaiProxyResponse (..),
waiProxyToSettings,
wpsSetIpHeader)
import qualified Network.HTTP.ReverseProxy.Rewrite as Rewrite
import Network.HTTP.Conduit (Manager)
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WarpTLS as WarpTLS
import Blaze.ByteString.Builder (copyByteString)
import Data.Monoid (mappend)
import Data.Default
import Keter.Types
import qualified Data.Vector as V
import Data.Text.Encoding (encodeUtf8)
import qualified Filesystem.Path.CurrentOS as F
import Network.HTTP.Types (mkStatus, status200,
status301, status302,
status303, status307,
status404)
import qualified Network.Wai as Wai
import Network.Wai.Application.Static (defaultFileServerSettings,
ssListing, staticApp)
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WarpTLS as WarpTLS
import Prelude hiding (FilePath, (++))
import WaiAppStatic.Listing (defaultListing)
-- | Mapping from virtual hostname to port number.
type HostLookup = ByteString -> IO (Maybe ProxyAction)

107
Keter/Types/Common.hs
View File

@ -1,10 +1,30 @@
{-# LANGUAGE TypeFamilies #-}
module Keter.Types.Common where
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Keter.Types.Common
( module Keter.Types.Common
, FilePath
, Text
, ByteString
, Set
, Map
, Exception
, SomeException
) where
import Data.Aeson (Object)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Keter.Prelude (KIO)
import Control.Exception (Exception, SomeException)
import Data.Aeson (Object)
import Data.ByteString (ByteString)
import Data.Map (Map)
import Data.Set (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)
-- | Name of the application. Should just be the basename of the application
-- file.
@ -31,3 +51,78 @@ 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 Text
| RemovingOldFolder FilePath
| ReceivedInotifyEvent Text
| ProcessWaiting FilePath
| OtherMessage Text
| ErrorStartingBundle Text SomeException
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 t) = "Sending old process TERM signal: " ++ unpack t
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
]
data KeterException = CannotParsePostgres FilePath
| ExitCodeFailure FilePath ExitCode
| NoPortsAvailable
| InvalidConfigFile Data.Yaml.ParseException
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)))|]

3
Keter/Types/V04.hs
View File

@ -7,11 +7,8 @@ import Prelude hiding (FilePath)
import Data.Yaml.FilePath
import Data.Aeson
import Control.Applicative
import Data.Text (Text)
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Filesystem.Path as F
import Filesystem.Path (FilePath)
import Data.Default
import Data.String (fromString)
import Data.Conduit.Network (HostPreference)

2
Keter/Types/V10.hs
View File

@ -3,14 +3,12 @@
{-# LANGUAGE FlexibleContexts #-}
module Keter.Types.V10 where
import Data.Text (Text)
import Data.Aeson (Object)
import Keter.Types.Common
import qualified Keter.Types.V04 as V04
import Data.Yaml.FilePath
import Data.Aeson (FromJSON (..), (.:), (.:?), Value (Object), withObject, (.!=))
import Control.Applicative ((<$>), (<*>), pure, (<|>))
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Filesystem.Path.CurrentOS as F
import Data.Default

1
keter.cabal
View File

@ -75,7 +75,6 @@ Library
Keter.AppManager
Keter.Main
Keter.PortPool
Keter.Prelude
Keter.Proxy
Keter.HostManager
Network.HTTP.ReverseProxy.Rewrite