2012-05-14 11:15:50 +04:00
|
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
2012-05-14 13:26:20 +04:00
|
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
2012-05-17 10:32:11 +04:00
|
|
|
{-# LANGUAGE TemplateHaskell #-}
|
2012-05-17 12:42:41 +04:00
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
2012-05-14 11:15:50 +04:00
|
|
|
module Keter.Prelude
|
2012-05-14 12:18:09 +04:00
|
|
|
( T.Text
|
2012-05-14 11:15:50 +04:00
|
|
|
, String
|
|
|
|
, P.Monad (..)
|
|
|
|
, P.Maybe (..)
|
|
|
|
, P.Bool (..)
|
|
|
|
, (P.$)
|
|
|
|
, (P..)
|
|
|
|
, LogMessage (..)
|
|
|
|
, log
|
2012-05-17 10:32:11 +04:00
|
|
|
, logEx
|
2012-05-14 12:03:57 +04:00
|
|
|
, KIO
|
2012-05-14 11:15:50 +04:00
|
|
|
, toString
|
|
|
|
, P.map
|
|
|
|
, (A.***)
|
|
|
|
, readFileLBS
|
2012-05-14 12:03:57 +04:00
|
|
|
, P.Either (..)
|
2012-05-14 13:26:20 +04:00
|
|
|
, P.either
|
2012-05-14 12:03:57 +04:00
|
|
|
, E.SomeException
|
|
|
|
, runKIO
|
|
|
|
, void
|
|
|
|
, liftIO
|
|
|
|
, forkKIO
|
2012-05-17 10:32:11 +04:00
|
|
|
, forkKIO'
|
2012-05-14 12:18:09 +04:00
|
|
|
, (++)
|
|
|
|
, P.minBound
|
|
|
|
, P.succ
|
|
|
|
, show
|
|
|
|
, Control.Monad.when
|
2012-05-14 13:26:20 +04:00
|
|
|
, fromText
|
|
|
|
, P.flip
|
|
|
|
, P.Show
|
|
|
|
, KeterException (..)
|
|
|
|
, E.toException
|
|
|
|
, newStdGen
|
2012-05-15 11:49:20 +04:00
|
|
|
, Default (..)
|
|
|
|
, P.Int
|
2012-05-15 12:38:54 +04:00
|
|
|
, (P.&&)
|
2012-05-15 11:49:20 +04:00
|
|
|
, (P.==)
|
2012-05-15 12:19:03 +04:00
|
|
|
, (P./=)
|
|
|
|
, (P.*)
|
2012-05-15 11:49:20 +04:00
|
|
|
, P.fromIntegral
|
|
|
|
, P.reverse
|
|
|
|
, P.otherwise
|
2012-05-15 12:38:54 +04:00
|
|
|
, timeout
|
|
|
|
, threadDelay
|
|
|
|
, P.id
|
|
|
|
, P.filter
|
|
|
|
, P.mapM_
|
|
|
|
, P.fmap
|
|
|
|
, P.not
|
2012-05-17 08:15:25 +04:00
|
|
|
, P.maybe
|
|
|
|
, (P.>)
|
2012-05-17 11:59:17 +04:00
|
|
|
, (P.<)
|
2012-05-17 08:15:25 +04:00
|
|
|
, (P.+)
|
2012-05-17 11:59:17 +04:00
|
|
|
, (P.-)
|
|
|
|
, getCurrentTime
|
2012-05-14 12:18:09 +04:00
|
|
|
-- * Filepath
|
|
|
|
, (F.</>)
|
2012-05-14 13:26:20 +04:00
|
|
|
, (F.<.>)
|
2012-05-14 12:18:09 +04:00
|
|
|
, F.FilePath
|
|
|
|
, F.isDirectory
|
2012-05-14 13:26:20 +04:00
|
|
|
, F.isFile
|
2012-05-14 12:18:09 +04:00
|
|
|
, F.removeTree
|
|
|
|
, F.createTree
|
2012-05-14 13:26:20 +04:00
|
|
|
, F.directory
|
|
|
|
, F.rename
|
2012-05-15 12:38:54 +04:00
|
|
|
, F.basename
|
|
|
|
, F.toText
|
|
|
|
, F.hasExtension
|
|
|
|
, F.listDirectory
|
2012-05-17 08:15:25 +04:00
|
|
|
, F.decodeString
|
2012-05-14 12:03:57 +04:00
|
|
|
-- * MVar
|
|
|
|
, M.MVar
|
|
|
|
, newMVar
|
2012-05-14 13:26:20 +04:00
|
|
|
, newEmptyMVar
|
2012-05-14 12:03:57 +04:00
|
|
|
, modifyMVar
|
2012-05-15 12:19:03 +04:00
|
|
|
, modifyMVar_
|
2012-05-14 12:03:57 +04:00
|
|
|
, swapMVar
|
2012-05-14 13:26:20 +04:00
|
|
|
, takeMVar
|
|
|
|
, putMVar
|
2012-05-14 12:18:09 +04:00
|
|
|
-- * IORef
|
|
|
|
, I.IORef
|
|
|
|
, newIORef
|
|
|
|
, atomicModifyIORef
|
2012-05-14 13:26:20 +04:00
|
|
|
-- * Chan
|
|
|
|
, C.Chan
|
|
|
|
, newChan
|
|
|
|
, readChan
|
|
|
|
, writeChan
|
2012-05-14 11:15:50 +04:00
|
|
|
) where
|
|
|
|
|
|
|
|
import qualified Filesystem.Path.CurrentOS as F
|
2012-05-14 12:18:09 +04:00
|
|
|
import qualified Filesystem as F
|
2012-05-14 11:15:50 +04:00
|
|
|
import qualified Data.Text as T
|
|
|
|
import qualified Prelude as P
|
|
|
|
import qualified Control.Arrow as A
|
|
|
|
import qualified Data.ByteString.Lazy as L
|
2012-05-14 12:03:57 +04:00
|
|
|
import Prelude (($), (.))
|
|
|
|
import qualified Control.Exception as E
|
|
|
|
import qualified Control.Monad
|
|
|
|
import qualified Control.Applicative
|
|
|
|
import qualified Control.Concurrent.MVar as M
|
2012-05-17 10:32:11 +04:00
|
|
|
import Control.Concurrent (forkIO, ThreadId)
|
2012-05-15 12:19:03 +04:00
|
|
|
import qualified Control.Concurrent
|
2012-05-14 12:18:09 +04:00
|
|
|
import qualified Data.IORef as I
|
|
|
|
import Data.Monoid (Monoid, mappend)
|
2012-05-14 13:26:20 +04:00
|
|
|
import qualified Data.Text.Lazy.Builder as B
|
|
|
|
import Data.Typeable (Typeable)
|
|
|
|
import qualified Control.Concurrent.Chan as C
|
|
|
|
import qualified System.Random as R
|
2012-05-15 11:49:20 +04:00
|
|
|
import Data.Default (Default (..))
|
|
|
|
import System.Exit (ExitCode)
|
|
|
|
import qualified Blaze.ByteString.Builder as Blaze
|
|
|
|
import qualified Blaze.ByteString.Builder.Char.Utf8
|
2012-05-15 12:19:03 +04:00
|
|
|
import qualified System.Timeout
|
2012-05-17 10:32:11 +04:00
|
|
|
import qualified Language.Haskell.TH.Syntax as TH
|
2012-05-17 11:59:17 +04:00
|
|
|
import qualified Data.Time
|
2012-05-14 11:15:50 +04:00
|
|
|
|
|
|
|
type String = T.Text
|
|
|
|
|
2012-05-14 12:03:57 +04:00
|
|
|
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 ()
|
2012-05-14 11:15:50 +04:00
|
|
|
|
|
|
|
data LogMessage
|
|
|
|
= ProcessCreated F.FilePath
|
2012-05-15 12:19:03 +04:00
|
|
|
| InvalidBundle F.FilePath E.SomeException
|
2012-05-14 11:15:50 +04:00
|
|
|
| ProcessDidNotStart F.FilePath
|
2012-05-17 10:32:11 +04:00
|
|
|
| ExceptionThrown T.Text E.SomeException
|
2012-05-15 11:49:20 +04:00
|
|
|
| RemovingPort P.Int
|
2012-05-15 12:19:03 +04:00
|
|
|
| UnpackingBundle F.FilePath F.FilePath
|
|
|
|
| TerminatingApp T.Text
|
|
|
|
| FinishedReloading T.Text
|
|
|
|
| TerminatingOldProcess T.Text
|
|
|
|
| RemovingOldFolder F.FilePath
|
2012-05-17 08:15:25 +04:00
|
|
|
| ReceivedInotifyEvent T.Text
|
2012-05-17 11:59:17 +04:00
|
|
|
| ProcessWaiting F.FilePath
|
2012-05-17 10:39:16 +04:00
|
|
|
|
|
|
|
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 dir) = P.concat
|
|
|
|
[ "Unpacking bundle '"
|
|
|
|
, F.encodeString b
|
|
|
|
, "' into folder: "
|
|
|
|
, F.encodeString dir
|
|
|
|
]
|
|
|
|
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
|
2012-05-17 11:59:17 +04:00
|
|
|
show (ProcessWaiting f) = "Process restarting too quickly, waiting before trying again: " ++ F.encodeString f
|
2012-05-14 11:15:50 +04:00
|
|
|
|
2012-05-17 10:32:11 +04:00
|
|
|
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))|]
|
|
|
|
|
2012-05-14 11:15:50 +04:00
|
|
|
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
|
|
|
|
|
2012-05-14 12:03:57 +04:00
|
|
|
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
|
|
|
|
|
2012-05-14 13:26:20 +04:00
|
|
|
newEmptyMVar :: KIO (M.MVar a)
|
|
|
|
newEmptyMVar = liftIO_ M.newEmptyMVar
|
|
|
|
|
2012-05-14 12:03:57 +04:00
|
|
|
modifyMVar :: M.MVar a -> (a -> KIO (a, b)) -> KIO b
|
|
|
|
modifyMVar m f = KIO $ \x -> M.modifyMVar m (\a -> unKIO (f a) x)
|
|
|
|
|
2012-05-15 12:19:03 +04:00
|
|
|
modifyMVar_ :: M.MVar a -> (a -> KIO a) -> KIO ()
|
|
|
|
modifyMVar_ m f = KIO $ \x -> M.modifyMVar_ m (\a -> unKIO (f a) x)
|
|
|
|
|
2012-05-14 12:03:57 +04:00
|
|
|
swapMVar :: M.MVar a -> a -> KIO a
|
|
|
|
swapMVar m = liftIO_ . M.swapMVar m
|
|
|
|
|
2012-05-14 13:26:20 +04:00
|
|
|
takeMVar :: M.MVar a -> KIO a
|
|
|
|
takeMVar = liftIO_ . M.takeMVar
|
|
|
|
|
|
|
|
putMVar :: M.MVar a -> a -> KIO ()
|
|
|
|
putMVar m = liftIO_ . M.putMVar m
|
|
|
|
|
2012-05-14 12:03:57 +04:00
|
|
|
forkKIO :: KIO () -> KIO ()
|
2012-05-17 10:32:11 +04:00
|
|
|
forkKIO = void . forkKIO'
|
|
|
|
|
|
|
|
forkKIO' :: KIO () -> KIO (P.Either E.SomeException ThreadId)
|
|
|
|
forkKIO' f = do
|
2012-05-14 12:03:57 +04:00
|
|
|
x <- KIO P.return
|
2012-05-17 10:32:11 +04:00
|
|
|
liftIO $ forkIO $ unKIO f x
|
2012-05-14 12:18:09 +04:00
|
|
|
|
|
|
|
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
|
2012-05-14 13:26:20 +04:00
|
|
|
|
|
|
|
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
|
2012-05-15 11:49:20 +04:00
|
|
|
instance FromText Blaze.Builder where
|
|
|
|
fromText = Blaze.ByteString.Builder.Char.Utf8.fromText
|
2012-05-14 13:26:20 +04:00
|
|
|
|
|
|
|
data KeterException = CannotParsePostgres F.FilePath
|
2012-05-15 11:49:20 +04:00
|
|
|
| ExitCodeFailure F.FilePath ExitCode
|
|
|
|
| NoPortsAvailable
|
2012-05-14 13:26:20 +04:00
|
|
|
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
|
2012-05-15 12:19:03 +04:00
|
|
|
|
|
|
|
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
|
2012-05-17 11:59:17 +04:00
|
|
|
|
|
|
|
getCurrentTime :: KIO Data.Time.UTCTime
|
|
|
|
getCurrentTime = liftIO_ Data.Time.getCurrentTime
|