bein-0.3.1: Bein/Types.hs

{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances #-}
module Bein.Types where

import Data.List ( intercalate )
import System.Posix.Types ( UserID )
import Control.Concurrent.STM ( TVar, atomically, readTVar )
import Control.Monad ()
import Control.Monad.Reader ( ReaderT(..), ask )
import Control.Monad.Trans ( liftIO )
import Control.Exception ( Exception )
import Data.Typeable ( Typeable )
import Database.HDBC ( fromSql, toSql, SqlValue(SqlString) )
import Database.HDBC.PostgreSQL
import Data.Convertible ( Convertible(..), convError )

newtype ExecutionID = ExecutionID Int deriving (Eq,Show,Read)

type BeinM a b = ReaderT a IO b

class BeinState a where
  configT :: a -> TVar Configuration
  db :: a -> Connection

configField :: BeinState s => (Configuration -> a) -> ReaderT s IO a
configField f = ask >>= liftIO.atomically.readTVar.configT >>= return.f

data Configuration = Configuration {
  file_repository :: String,
  scratch_directory :: String,
  static_content_directory :: FilePath,
  perl_executable :: String,
  r_executable :: String,
  max_executions :: Int,
  minion_command :: String, -- "/path/to/minion -d %s -e %d" where %s will be the directory
                            -- to work in, and %d the id of the execution to run.
  daemon_port :: String, -- By default /tmp/.s.BEIND
  minion_port :: String, -- By default .s.minion in the execution directory
  http_port :: Int, -- default 8082
  http_base_url :: String,
  http_base_path :: String,
  template_path :: String,
  authentication :: Authentication
} deriving (Eq,Show,Read)


instance Convertible SqlValue Authentication where
  safeConvert x = case readsPrec 1 (fromSql x) of
    [] -> convError "Invalid authentication type" x
    [(v,"")] -> return v
    _  -> convError "Read multiple authentication types in string.  Make up your mind!" x
  
instance Convertible Authentication SqlValue where
  safeConvert = return . toSql . show

instance Convertible SqlValue ExecutionID where
  safeConvert = return . ExecutionID . fromSql
  
instance Convertible ExecutionID SqlValue where
  safeConvert (ExecutionID x) = return $ toSql x

unExecutionID :: ExecutionID -> Int
unExecutionID (ExecutionID x) = x

instance Convertible [ExecutionID] SqlValue where
  safeConvert xs = let xs' = map (show.unExecutionID) xs
                   in return $ SqlString $ "{" ++ intercalate "," xs' ++ "}"

data ConfigurationError = InvalidAuthentication String deriving (Eq,Show,Read,Typeable)

instance Exception ConfigurationError 

data Authentication = None | SameUser | OnlyUser UserID deriving (Eq,Show,Read,Typeable)

data AuthenticationFailed = AuthenticationFailed deriving (Show,Typeable)
instance Exception AuthenticationFailed

data BeinError = NoDatabaseServer String
               | DatabaseAccessError String
               | MissingConfigurationField String
               | NoScratchDirectory String
               | CannotWriteToScratchDirectory String
               | NoFileDirectory String
               | CannotWriteToFileDirectory String
               | MissingFile Int String String -- ID, user_filename, stored_as
               | MinionExecutionFailed String
               | UnknownExecution ExecutionID
               | NoSuchJob ExecutionID
               | FailedToKillJob ExecutionID
               | UnknownCommand String
               deriving (Eq,Show,Read)
                        
errorNumber :: BeinError -> Int
errorNumber (NoDatabaseServer _) = 10
errorNumber (DatabaseAccessError _) = 15
errorNumber (MissingConfigurationField _) = 17
errorNumber (NoScratchDirectory _) = 20
errorNumber (CannotWriteToScratchDirectory _) = 25
errorNumber (NoFileDirectory _) = 30
errorNumber (CannotWriteToFileDirectory _) = 35
errorNumber (MissingFile _ _ _) = 36
errorNumber (MinionExecutionFailed _) = 100
errorNumber (UnknownExecution _) = 110
errorNumber (NoSuchJob _) = 120
errorNumber (FailedToKillJob _) = 150
errorNumber (UnknownCommand _) = 200

errorName :: BeinError -> String
errorName (NoDatabaseServer _) = "no database server"
errorName (DatabaseAccessError _) = "database access error"
errorName (MissingConfigurationField _) = "missing configuration field"
errorName (NoScratchDirectory _) = "no scratch directory"
errorName (CannotWriteToScratchDirectory _) = "cannot write to scratch directory"
errorName (NoFileDirectory _) = "no file directory"
errorName (CannotWriteToFileDirectory _) = "cannot write to file directory"
errorName (MissingFile _ _ _) = "missing file"
errorName (MinionExecutionFailed _) = "minion execution failed"
errorName (UnknownExecution _) = "unknown execution"
errorName (NoSuchJob _) = "no such job"
errorName (FailedToKillJob _) = "failed to kill job"
errorName (UnknownCommand _) = "unknown command"