keter/Keter/Prelude.hs

309 lines
7.7 KiB
Haskell
Raw Normal View History

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