mighttpd2-3.4.1/0000755000000000000000000000000013052760261011611 5ustar0000000000000000mighttpd2-3.4.1/LICENSE0000644000000000000000000000276513052760261012630 0ustar0000000000000000Copyright (c) 2011, IIJ Innovation Institute Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. mighttpd2-3.4.1/mighttpd2.cabal0000644000000000000000000001120213052760261014473 0ustar0000000000000000Name: mighttpd2 Version: 3.4.1 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE Synopsis: High performance web server on WAI/warp Description: High performance web server to handle static files and CGI on WAI/warp. Reverse proxy functionality is also provided to connect web applications behind. Homepage: http://www.mew.org/~kazu/proj/mighttpd/ Category: Network, Web Cabal-Version: >= 1.10 Build-Type: Simple Data-Dir: conf Data-Files: example.conf example.route Flag tls Description: Support http over tls (https). Default: False Library Default-Language: Haskell2010 GHC-Options: -Wall Exposed-Modules: Program.Mighty Program.Mighty.ByteString Program.Mighty.Config Program.Mighty.Network Program.Mighty.Parser Program.Mighty.Process Program.Mighty.Report Program.Mighty.Resource Program.Mighty.Route Program.Mighty.Signal Build-Depends: base >= 4.0 && < 5 , array , async , auto-update , blaze-builder , byteorder , bytestring , case-insensitive , conduit >= 1.1 , conduit-extra , directory , filepath , http-date , http-types , io-choice , network , parsec >= 3 , resourcet , streaming-commons , unix , unix-time , unordered-containers , wai >= 3.2 && < 3.3 , wai-app-file-cgi >= 3.1.1 && < 3.2 , warp >= 3.2.7 && < 3.3 Executable mighty Default-Language: Haskell2010 HS-Source-Dirs: src Main-Is: Mighty.hs GHC-Options: -Wall -threaded -rtsopts if flag(tls) Cpp-Options: -DHTTP_OVER_TLS Build-Depends: async Build-Depends: base >= 4.0 && < 5 , bytestring , directory , filepath , http-client >= 0.5 , http-date , http-types , mighttpd2 , network , conduit-extra , transformers , unix , streaming-commons , wai >= 3.2 && < 3.3 , wai-app-file-cgi >= 3.1.1 && < 3.2 , wai-logger >= 2.3.0 , warp >= 3.2.7 && < 3.3 , wai-http2-extra >= 0.1 if flag(tls) Build-Depends: tls , warp-tls >= 3.2 && < 3.3 Other-Modules: Mighty Server WaiApp Paths_mighttpd2 Executable mighty-mkindex Default-Language: Haskell2010 HS-Source-Dirs: utils, src Main-Is: mkindex.hs GHC-Options: -Wall Build-Depends: base >= 4 && < 5 , directory , old-locale , time , unix Executable mightyctl Default-Language: Haskell2010 HS-Source-Dirs: utils, src Main-Is: mightyctl.hs GHC-Options: -Wall Build-Depends: base >= 4 && < 5 , unix , mighttpd2 Test-Suite spec Default-Language: Haskell2010 Main-Is: Spec.hs Hs-Source-Dirs: test, src Type: exitcode-stdio-1.0 Other-Modules: ConfigSpec RouteSpec Build-Depends: base >= 4 && < 5 , hspec >= 1.3 , mighttpd2 , http-client >= 0.5 if flag(tls) Build-Depends: tls , warp-tls >= 3.2 && < 3.3 Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/mighttpd2.git mighttpd2-3.4.1/Setup.hs0000644000000000000000000000005613052760261013246 0ustar0000000000000000import Distribution.Simple main = defaultMain mighttpd2-3.4.1/conf/0000755000000000000000000000000013052760261012536 5ustar0000000000000000mighttpd2-3.4.1/conf/example.conf0000644000000000000000000000165713052760261015051 0ustar0000000000000000# Example configuration for Mighttpd 2 Port: 80 # IP address or "*" Host: * Debug_Mode: Yes # Yes or No # If available, "nobody" is much more secure for User:. User: root # If available, "nobody" is much more secure for Group:. Group: root Pid_File: /var/run/mighty.pid Logging: Yes # Yes or No Log_File: /var/log/mighty # The directory must be writable by User: Log_File_Size: 16777216 # bytes Log_Backup_Number: 10 Index_File: index.html Index_Cgi: index.cgi Status_File_Dir: /usr/local/share/mighty/status Connection_Timeout: 30 # seconds Fd_Cache_Duration: 10 # seconds # Server_Name: Mighttpd/3.x.y Tls_Port: 443 Tls_Cert_File: cert.pem # should change this with an absolute path # should change this with comma-separated absolute paths Tls_Chain_Files: chain.pem # Currently, Tls_Key_File must not be encrypted. Tls_Key_File: privkey.pem # should change this with an absolute path Service: 0 # 0 is HTTP only, 1 is HTTPS only, 2 is both mighttpd2-3.4.1/conf/example.route0000644000000000000000000000125313052760261015252 0ustar0000000000000000# Example routing for Mighttpd 2 # Domain lists [localhost www.example.com] # Entries are looked up in the specified order # All paths must end with "/" # A path to CGI scripts should be specified with "=>" /~alice/cgi-bin/ => /home/alice/public_html/cgi-bin/ # A path to static files should be specified with "->" /~alice/ -> /home/alice/public_html/ /cgi-bin/ => /export/cgi-bin/ # Reverse proxy rules should be specified with ">>" # /path >> host:port/path2 # Either "host" or ":port" can be committed, but not both. /app/cal/ >> example.net/calendar/ # Yesod app in the same server /app/wiki/ >> 127.0.0.1:3000/ / -> /export/www/ mighttpd2-3.4.1/Program/0000755000000000000000000000000013052760261013220 5ustar0000000000000000mighttpd2-3.4.1/Program/Mighty.hs0000644000000000000000000000125513052760261015020 0ustar0000000000000000-- | Special library for Mighty. module Program.Mighty ( -- * Parsers module Program.Mighty.Config , module Program.Mighty.Route , module Program.Mighty.Parser -- * State , module Program.Mighty.Report -- * Utilities , module Program.Mighty.ByteString , module Program.Mighty.Network , module Program.Mighty.Process , module Program.Mighty.Resource , module Program.Mighty.Signal ) where import Program.Mighty.ByteString import Program.Mighty.Config import Program.Mighty.Network import Program.Mighty.Parser import Program.Mighty.Process import Program.Mighty.Report import Program.Mighty.Resource import Program.Mighty.Route import Program.Mighty.Signal mighttpd2-3.4.1/Program/Mighty/0000755000000000000000000000000013052760261014461 5ustar0000000000000000mighttpd2-3.4.1/Program/Mighty/ByteString.hs0000644000000000000000000000052613052760261017112 0ustar0000000000000000module Program.Mighty.ByteString where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS -- | Converting showalbe data to 'ByteString'. bshow :: Show a => a -> ByteString bshow = BS.pack . show infixr 5 +++ -- | Appending two 'ByteString'. (+++) :: ByteString -> ByteString -> ByteString (+++) = BS.append mighttpd2-3.4.1/Program/Mighty/Config.hs0000644000000000000000000001273513052760261016232 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, OverloadedStrings #-} {-# LANGUAGE CPP #-} module Program.Mighty.Config ( -- * Parsing a configuration file. parseOption -- * Creating 'Option'. , defaultOption -- * Types , Option(..) ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative hiding (many,optional,(<|>)) #endif import Program.Mighty.Parser import Text.Parsec import Text.Parsec.ByteString.Lazy ---------------------------------------------------------------- -- | Getting a default 'Option'. defaultOption :: String -- ^ A default server name (e.g. \"Mighttpd/3.0.0\") -> Option defaultOption svrnm = Option { opt_port = 8080 , opt_host = "*" , opt_debug_mode = True , opt_user = "root" , opt_group = "root" , opt_pid_file = "/var/run/mighty.pid" , opt_logging = True , opt_log_file = "/var/log/mighty" , opt_log_file_size = 16777216 , opt_log_backup_number = 10 , opt_index_file = "index.html" , opt_index_cgi = "index.cgi" , opt_status_file_dir = "/usr/local/share/mighty/status" , opt_connection_timeout = 30 , opt_proxy_timeout = 0 , opt_fd_cache_duration = 10 , opt_server_name = svrnm , opt_routing_file = Nothing , opt_tls_port = 443 , opt_tls_cert_file = "cert.pem" , opt_tls_chain_files = "chain.pem" , opt_tls_key_file = "key.pem" , opt_service = 0 , opt_report_file = "/tmp/mighty_report" } data Option = Option { opt_port :: !Int , opt_host :: !String , opt_debug_mode :: !Bool , opt_user :: !String , opt_group :: !String , opt_pid_file :: !FilePath , opt_logging :: !Bool , opt_log_file :: !FilePath , opt_log_file_size :: !Int , opt_log_backup_number :: !Int , opt_index_file :: !FilePath , opt_index_cgi :: !FilePath , opt_status_file_dir :: !FilePath , opt_connection_timeout :: !Int , opt_proxy_timeout :: !Int , opt_fd_cache_duration :: !Int , opt_server_name :: !String , opt_routing_file :: !(Maybe FilePath) , opt_tls_port :: !Int , opt_tls_cert_file :: !FilePath , opt_tls_chain_files :: !FilePath , opt_tls_key_file :: !FilePath , opt_service :: !Int , opt_report_file :: !FilePath } deriving (Eq,Show) ---------------------------------------------------------------- -- | Parsing a configuration file to get an 'Option'. parseOption :: FilePath -> String -> IO Option parseOption file svrnm = makeOpt (defaultOption svrnm) <$> parseConfig file ---------------------------------------------------------------- makeOpt :: Option -> [Conf] -> Option makeOpt def conf = Option { opt_port = get "Port" opt_port , opt_host = get "Host" opt_host , opt_debug_mode = get "Debug_Mode" opt_debug_mode , opt_user = get "User" opt_user , opt_group = get "Group" opt_group , opt_pid_file = get "Pid_File" opt_pid_file , opt_logging = get "Logging" opt_logging , opt_log_file = get "Log_File" opt_log_file , opt_log_file_size = get "Log_File_Size" opt_log_file_size , opt_log_backup_number = get "Log_Backup_Number" opt_log_backup_number , opt_index_file = get "Index_File" opt_index_file , opt_index_cgi = get "Index_Cgi" opt_index_cgi , opt_status_file_dir = get "Status_File_Dir" opt_status_file_dir , opt_connection_timeout = get "Connection_Timeout" opt_connection_timeout , opt_proxy_timeout = get "Proxy_Timeout" opt_proxy_timeout , opt_fd_cache_duration = get "Fd_Cache_Duration" opt_fd_cache_duration , opt_server_name = get "Server_Name" opt_server_name , opt_routing_file = Nothing , opt_tls_port = get "Tls_Port" opt_tls_port , opt_tls_cert_file = get "Tls_Cert_File" opt_tls_cert_file , opt_tls_chain_files = get "Tls_Chain_Files" opt_tls_chain_files , opt_tls_key_file = get "Tls_Key_File" opt_tls_key_file , opt_service = get "Service" opt_service , opt_report_file = get "ReportFile" opt_report_file } where get k func = maybe (func def) fromConf $ lookup k conf ---------------------------------------------------------------- type Conf = (String, ConfValue) data ConfValue = CV_Int Int | CV_Bool Bool | CV_String String deriving (Eq,Show) class FromConf a where fromConf :: ConfValue -> a instance FromConf Int where fromConf (CV_Int n) = n fromConf _ = error "fromConf int" instance FromConf Bool where fromConf (CV_Bool b) = b fromConf _ = error "fromConf bool" instance FromConf String where fromConf (CV_String s) = s fromConf _ = error "fromConf string" ---------------------------------------------------------------- parseConfig :: FilePath -> IO [Conf] parseConfig = parseFile config ---------------------------------------------------------------- config :: Parser [Conf] config = commentLines *> many cfield <* eof where cfield = field <* commentLines field :: Parser Conf field = (,) <$> key <*> (sep *> value) key :: Parser String key = many1 (oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_") <* spcs sep :: Parser () sep = () <$ char ':' *> spcs value :: Parser ConfValue value = choice [try cv_int, try cv_bool, cv_string] -- Trailing should be included in try to allow IP addresses. cv_int :: Parser ConfValue cv_int = CV_Int . read <$> many1 digit <* trailing cv_bool :: Parser ConfValue cv_bool = CV_Bool True <$ string "Yes" <* trailing <|> CV_Bool False <$ string "No" <* trailing cv_string :: Parser ConfValue cv_string = CV_String <$> many (noneOf " \t\n") <* trailing mighttpd2-3.4.1/Program/Mighty/Network.hs0000644000000000000000000000122413052760261016445 0ustar0000000000000000module Program.Mighty.Network ( daemonize ) where import Control.Monad import System.Exit import System.Posix -- | Run a program detaching its terminal. daemonize :: IO () -> IO () daemonize program = ensureDetachTerminalCanWork $ do detachTerminal ensureNeverAttachTerminal $ do changeWorkingDirectory "/" void $ setFileCreationMask 0 mapM_ closeFd [stdInput, stdOutput, stdError] program where ensureDetachTerminalCanWork p = do void $ forkProcess p exitSuccess ensureNeverAttachTerminal p = do void $ forkProcess p exitSuccess detachTerminal = void createSession mighttpd2-3.4.1/Program/Mighty/Parser.hs0000644000000000000000000000411613052760261016253 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Parsers for Mighty module Program.Mighty.Parser ( -- * Utilities parseFile -- * Parsers , spcs , spcs1 , spc , commentLines , trailing , comment ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative hiding (many,(<|>)) #endif import Control.Exception import qualified Data.ByteString.Lazy.Char8 as BL import System.IO import Text.Parsec import Text.Parsec.ByteString.Lazy -- $setup -- >>> import Data.Either -- >>> let isLeft = either (const True) (const False) -- | Parsing a file. -- If parsing fails, an 'IOException' is thrown. parseFile :: Parser a -> FilePath -> IO a parseFile p file = do hdl <- openFile file ReadMode hSetEncoding hdl latin1 bs <- BL.hGetContents hdl case parse p "parseFile" bs of Right x -> return x Left e -> throwIO . userError . show $ e -- | 'Parser' to consume zero or more white spaces -- -- >>> parse spcs "" " " -- Right () -- >>> parse spcs "" "" -- Right () spcs :: Parser () spcs = () <$ many spc -- | 'Parser' to consume one or more white spaces -- -- >>> parse spcs1 "" " " -- Right () -- >>> parse spcs1 "" " " -- Right () -- >>> isLeft $ parse spcs1 "" "" -- True spcs1 :: Parser () spcs1 = () <$ many1 spc -- | 'Parser' to consume exactly one white space -- -- >>> parse spc "" " " -- Right ' ' -- >>> isLeft $ parse spc "" "" -- True spc :: Parser Char spc = satisfy (`elem` " \t") -- | 'Parser' to consume one or more comment lines -- -- >>> parse commentLines "" "# comments\n# comments\n# comments\n" -- Right () commentLines :: Parser () commentLines = () <$ many commentLine where commentLine = trailing -- | 'Parser' to consume a trailing comment -- -- >>> parse trailing "" "# comments\n" -- Right () -- >>> isLeft $ parse trailing "" "X# comments\n" -- True trailing :: Parser () trailing = () <$ (spcs *> comment *> newline <|> spcs *> newline) -- | 'Parser' to consume a trailing comment -- -- >>> parse comment "" "# comments" -- Right () -- >>> isLeft $ parse comment "" "foo" -- True comment :: Parser () comment = () <$ char '#' <* many (noneOf "\n") mighttpd2-3.4.1/Program/Mighty/Process.hs0000644000000000000000000000512013052760261016431 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Program.Mighty.Process ( getMightyPid ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Monad.Trans.Resource (runResourceT) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.Process import Data.Function import Data.List import Data.Ord import System.Posix.Types ---------------------------------------------------------------- data PsResult = PsResult { uid :: ByteString , pid :: ProcessID , ppid :: ProcessID , command :: ByteString } deriving (Eq, Show) toPsResult :: [ByteString] -> PsResult toPsResult (a:b:c:_:_:_:_:h:_) = PsResult { uid = a , pid = maybe 0 (fromIntegral . fst) $ BS.readInt b , ppid = maybe 0 (fromIntegral . fst) $ BS.readInt c , command = h } toPsResult _ = PsResult "unknown" 0 0 "unknown" ---------------------------------------------------------------- runPS :: IO [PsResult] runPS = snd <$> runResourceT (sourceCmdWithConsumer "ps -ef" consumer) where consumer = CB.lines $= CL.map BS.words $= CL.map toPsResult $= CL.filter mighty $= CL.consume commandName = last . split '/' . command mighty ps = "mighty" `BS.isInfixOf` name && not ("mightyctl" `BS.isInfixOf` name) where name = commandName ps ---------------------------------------------------------------- findParent :: [PsResult] -> [PsResult] findParent ps = deleteAloneChild $ masters ++ candidates where iAmMaster p = ppid p == 1 masters = filter iAmMaster ps rest = filter (not.iAmMaster) ps candidates = map head $ filter (\xs -> length xs == 1) -- master is alone $ groupBy ((==) `on` ppid) $ sortBy (comparing ppid) rest deleteAloneChild :: [PsResult] -> [PsResult] deleteAloneChild [] = [] deleteAloneChild (p:ps) = p : deleteAloneChild (filter noParent ps) where parent = pid p noParent x = ppid x /= parent ---------------------------------------------------------------- -- | Getting the process id of a running Mighty. getMightyPid :: IO [ProcessID] getMightyPid = (map pid . findParent) <$> runPS ---------------------------------------------------------------- split :: Char -> ByteString -> [ByteString] split _ "" = [] split c s = case BS.break (c==) s of ("",r) -> split c (BS.tail r) (s',"") -> [s'] (s',r) -> s' : split c (BS.tail r) mighttpd2-3.4.1/Program/Mighty/Report.hs0000644000000000000000000000527113052760261016275 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Program.Mighty.Report ( Reporter , initReporter , finReporter , report , reportDo , warpHandler , printStdout ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Exception import qualified Control.Exception as E (catch) import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.UnixTime import GHC.IO.Exception (IOErrorType(..)) import Network.Wai import Network.Wai.Handler.Warp (InvalidRequest) import Network.Wai.Handler.Warp.Internal (TimeoutThread(..)) import System.IO import System.IO.Error (ioeGetErrorType) import System.Posix (getProcessID) import Program.Mighty.ByteString data Method = FileOnly | FileAndStdout deriving Eq data Reporter = Reporter Method Handle initReporter :: Bool -> FilePath -> IO (Either SomeException Reporter) initReporter debug reportFile = try $ Reporter method <$> openFile reportFile AppendMode where method | debug = FileAndStdout | otherwise = FileOnly finReporter :: Reporter -> IO () finReporter (Reporter _ rpthdl) = hClose rpthdl report :: Reporter -> ByteString -> IO () report (Reporter method rpthdl) msg = handle (\(SomeException _) -> return ()) $ do pid <- BS.pack . show <$> getProcessID tm <- getUnixTime >>= formatUnixTime "%d %b %Y %H:%M:%S" let logmsg = BS.concat [tm, ": pid = ", pid, ": ", msg, "\n"] BS.hPutStr rpthdl logmsg hFlush rpthdl when (method == FileAndStdout) $ BS.putStr logmsg ---------------------------------------------------------------- reportDo :: Reporter -> IO () -> IO () reportDo rpt act = act `E.catch` warpHandler rpt Nothing ---------------------------------------------------------------- warpHandler :: Reporter -> Maybe Request -> SomeException -> IO () warpHandler rpt _ e = throwIO e `catches` handlers where handlers = [Handler ah, Handler th, Handler ih, Handler oh, Handler sh] ah :: AsyncException -> IO () ah ThreadKilled = norecode ah x = recode x th :: TimeoutThread -> IO () th TimeoutThread = norecode ih :: InvalidRequest -> IO () ih _ = norecode oh :: IOException -> IO () oh x | et `elem` ignEts = norecode | otherwise = recode x where et = ioeGetErrorType x ignEts = [ResourceVanished, InvalidArgument] sh :: SomeException -> IO () sh x = recode x norecode = return () recode :: Exception e => e -> IO () recode = report rpt . bshow ---------------------------------------------------------------- printStdout :: Maybe Request -> SomeException -> IO () printStdout _ x = print x >> hFlush stdout mighttpd2-3.4.1/Program/Mighty/Resource.hs0000644000000000000000000000236413052760261016611 0ustar0000000000000000{-# LANGUAGE CPP #-} module Program.Mighty.Resource ( amIrootUser , setGroupUser , unlimit ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Control.Exception import Control.Monad import System.Posix ---------------------------------------------------------------- -- | Checking if this process has the root privilege. amIrootUser :: IO Bool amIrootUser = (== 0) <$> getRealUserID ---------------------------------------------------------------- -- | Setting user and group. setGroupUser :: String -- ^ User -> String -- ^ Group -> IO () setGroupUser user group = do root <- amIrootUser when root $ do getGroupEntryForName group >>= setGroupID . groupID getUserEntryForName user >>= setUserID . userID ---------------------------------------------------------------- -- | Set the limit of open files. unlimit :: Integer -> IO () unlimit limit = handle (\(SomeException _) -> return ()) $ do hard <- hardLimit <$> getResourceLimit ResourceOpenFiles let lim = if hard == ResourceLimitInfinity then ResourceLimits (ResourceLimit limit) hard else ResourceLimits hard hard setResourceLimit ResourceOpenFiles lim mighttpd2-3.4.1/Program/Mighty/Route.hs0000644000000000000000000000720713052760261016121 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, TupleSections #-} {-# LANGUAGE CPP #-} module Program.Mighty.Route ( -- * Paring a routing file parseRoute -- * Types , RouteDB , Route(..) , Block(..) , Src , Dst , Domain , Port -- * RouteDBRef , RouteDBRef , newRouteDBRef , readRouteDBRef , writeRouteDBRef ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative hiding (many,(<|>)) #endif import Control.Monad import Data.ByteString import qualified Data.ByteString.Char8 as BS import Data.IORef import Network.Wai.Application.Classic import Text.Parsec import Text.Parsec.ByteString.Lazy import Program.Mighty.Parser ---------------------------------------------------------------- -- | A logical path specified in URL. type Src = Path -- | A physical path in a file system. type Dst = Path type Domain = ByteString type Port = Int data Block = Block [Domain] [Route] deriving (Eq,Show) data Route = RouteFile Src Dst | RouteRedirect Src Dst | RouteCGI Src Dst | RouteRevProxy Src Dst Domain Port deriving (Eq,Show) type RouteDB = [Block] ---------------------------------------------------------------- -- | Parsing a route file. parseRoute :: FilePath -> Domain -- ^ A default domain, typically \"localhost\" -> Port -- ^ A default port, typically 80. -> IO RouteDB parseRoute file ddom dport = parseFile (routeDB ddom dport) file routeDB :: Domain -> Port -> Parser RouteDB routeDB ddom dport = commentLines *> many1 (block ddom dport) <* eof block :: Domain -> Port -> Parser Block block ddom dport = Block <$> cdomains <*> many croute where cdomains = domains <* commentLines croute = route ddom dport <* commentLines domains :: Parser [Domain] domains = open *> doms <* close <* trailing where open = () <$ char '[' *> spcs close = () <$ char ']' *> spcs doms = (domain `sepBy1` sep) <* spcs domain = BS.pack <$> many1 (noneOf "[], \t\n") sep = () <$ spcs1 data Op = OpFile | OpCGI | OpRevProxy | OpRedirect route :: Domain -> Port -> Parser Route route ddom dport = do s <- src o <- op case o of OpFile -> RouteFile s <$> dst <* trailing OpRedirect -> RouteRedirect s <$> dst' <* trailing OpCGI -> RouteCGI s <$> dst <* trailing OpRevProxy -> do (dom,prt,d) <- domPortDst ddom dport return $ RouteRevProxy s d dom prt where src = path dst = path dst' = path' op0 = OpFile <$ string "->" <|> OpRedirect <$ string "<<" <|> OpCGI <$ string "=>" <|> OpRevProxy <$ string ">>" op = op0 <* spcs path :: Parser Path path = do c <- char '/' BS.pack . (c:) <$> many (noneOf "[], \t\n") <* spcs path' :: Parser Path path' = BS.pack <$> many (noneOf "[], \t\n") <* spcs -- [host1][:port2]/path2 domPortDst :: Domain -> Port -> Parser (Domain, Port, Dst) domPortDst ddom dport = (ddom,,) <$> port <*> path <|> try((,,) <$> domain <*> port <*> path) <|> (,dport,) <$> domain <*> path where domain = BS.pack <$> many1 (noneOf ":/[], \t\n") port = do void $ char ':' read <$> many1 (oneOf ['0'..'9']) ---------------------------------------------------------------- newtype RouteDBRef = RouteDBRef (IORef RouteDB) newRouteDBRef :: RouteDB -> IO RouteDBRef newRouteDBRef rout = RouteDBRef <$> newIORef rout readRouteDBRef :: RouteDBRef -> IO RouteDB readRouteDBRef (RouteDBRef ref) = readIORef ref writeRouteDBRef :: RouteDBRef -> RouteDB -> IO () writeRouteDBRef (RouteDBRef ref) rout = writeIORef ref rout mighttpd2-3.4.1/Program/Mighty/Signal.hs0000644000000000000000000000147613052760261016242 0ustar0000000000000000module Program.Mighty.Signal ( -- * Signals sigStop , sigReload , sigRetire , sigInfo -- * Signal handling , setHandler ) where import Control.Monad import System.Posix ---------------------------------------------------------------- -- | The signal to stop Mighty. sigStop :: Signal sigStop = sigTERM -- | The signal to reload a configration file. sigReload :: Signal sigReload = sigHUP -- | The signal to top accepting new connections and to finish current connections. sigRetire :: Signal sigRetire = sigQUIT -- | The signal to get information from Mighty. sigInfo :: Signal sigInfo = sigUSR2 ---------------------------------------------------------------- -- | Setting 'Handler' for 'Signal'. setHandler :: Signal -> Handler -> IO () setHandler sig func = void $ installHandler sig func Nothing mighttpd2-3.4.1/src/0000755000000000000000000000000013052760261012400 5ustar0000000000000000mighttpd2-3.4.1/src/Mighty.hs0000644000000000000000000000610613052760261014200 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} module Main where #ifndef HTTP_OVER_TLS import Control.Monad (when) #endif import Data.Version (showVersion) import Network.Wai.Application.Classic hiding (()) import System.Directory (getCurrentDirectory) import System.Environment (getArgs) import System.Exit (exitFailure) import System.FilePath (addTrailingPathSeparator, isAbsolute, normalise, ()) import System.IO import Program.Mighty import Server import Paths_mighttpd2 as P ---------------------------------------------------------------- programName :: String programName = "Mighttpd" programVersion :: String programVersion = showVersion P.version ---------------------------------------------------------------- main :: IO () main = do (opt,route) <- getOptRoute checkTLS opt let reportFile = reportFileName opt debug = opt_debug_mode opt rpt <- initReporter debug reportFile >>= checkReporter reportFile let run = server opt rpt route if debug then run else background opt run where getOptRoute = getArgs >>= eachCase svrnm = programName ++ "/" ++ programVersion eachCase args | n == 0 = do root <- amIrootUser let opt | root = (defaultOption svrnm) { opt_port = 80 } | otherwise = defaultOption svrnm dir <- getCurrentDirectory let dst = fromString . addTrailingPathSeparator $ dir route = [Block ["*"] [RouteFile "/" dst]] return (opt, route) | n == 2 = do let config_file = args !! 0 routing_file <- getAbsoluteFile (args !! 1) opt <- parseOption config_file svrnm route <- parseRoute routing_file defaultDomain defaultPort let opt' = opt {opt_routing_file = Just routing_file} return (opt',route) | otherwise = do hPutStrLn stderr "Usage: mighty" hPutStrLn stderr " mighty config_file routing_file" exitFailure where n = length args getAbsoluteFile file | isAbsolute file = return file | otherwise = do dir <- getCurrentDirectory return $ dir normalise file checkReporter _ (Right rpt) = return rpt checkReporter reportFile (Left e) = do hPutStrLn stderr $ reportFile ++ " is not writable" hPrint stderr e exitFailure #ifdef HTTP_OVER_TLS checkTLS _ = return () #else checkTLS opt = when (opt_service opt > 1) $ do hPutStrLn stderr "This mighty does not support TLS" exitFailure #endif ---------------------------------------------------------------- background :: Option -> IO () -> IO () background opt svr = do putStrLn $ "Serving on port " ++ show port ++ " and detaching this terminal..." putStrLn $ "(If errors occur, they will be written in \"" ++ reportFileName opt ++ "\".)" hFlush stdout daemonize svr where port = opt_port opt reportFileName :: Option -> FilePath reportFileName opt | port == 80 = rfile | otherwise = rfile ++ show port where rfile = opt_report_file opt port = opt_port opt mighttpd2-3.4.1/src/Server.hs0000644000000000000000000002112513052760261014203 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP, BangPatterns #-} module Server (server, defaultDomain, defaultPort) where import Control.Concurrent (runInUnboundThread) import Control.Exception (try) import Control.Monad (unless, when) import qualified Data.ByteString.Char8 as BS import Data.Char (isSpace) import Data.List (dropWhile, dropWhileEnd, break) import Data.Streaming.Network (bindPortTCP) import Network (Socket, sClose) import qualified Network.HTTP.Client as H import Network.Wai.Application.Classic hiding (()) import Network.Wai.Handler.Warp import Network.Wai.Logger import System.Exit (ExitCode(..), exitSuccess) import System.IO import System.IO.Error (ioeGetErrorString) import System.Posix (exitImmediately, Handler(..), getProcessID, setFileMode) import System.Posix.Signals (sigCHLD) import Program.Mighty import WaiApp import qualified Network.Wai.Middleware.Push.Referer as P #ifdef HTTP_OVER_TLS import Control.Concurrent.Async (concurrently) import Control.Monad (void) import Network.Wai.Handler.WarpTLS #else data TLSSettings = TLSSettings #endif ---------------------------------------------------------------- defaultDomain :: Domain defaultDomain = "localhost" defaultPort :: Int defaultPort = 80 openFileNumber :: Integer openFileNumber = 10000 logBufferSize :: Int logBufferSize = 4 * 1024 * 10 managerNumber :: Int managerNumber = 1024 -- FIXME ---------------------------------------------------------------- type LogRemover = IO () ---------------------------------------------------------------- server :: Option -> Reporter -> RouteDB -> IO () server opt rpt route = reportDo rpt $ do unlimit openFileNumber svc <- openService opt unless debug writePidFile rdr <- newRouteDBRef route tlsSetting <- getTlsSetting opt setGroupUser (opt_user opt) (opt_group opt) logCheck logtype (zdater,_) <- clockDateCacher ap <- initLogger FromSocket logtype zdater let lgr = apacheLogger ap remover = logRemover ap pushlgr = serverpushLogger ap mgr <- getManager opt setHandlers opt rpt svc remover rdr report rpt "Mighty started" runInUnboundThread $ mighty opt rpt svc lgr pushlgr mgr rdr tlsSetting report rpt "Mighty retired" finReporter rpt remover exitSuccess where debug = opt_debug_mode opt port = opt_port opt pidfile | port == 80 = opt_pid_file opt | otherwise = opt_pid_file opt ++ show port writePidFile = do pid <- getProcessID writeFile pidfile $ show pid ++ "\n" setFileMode pidfile 0o644 logspec = FileLogSpec { log_file = opt_log_file opt , log_file_size = fromIntegral $ opt_log_file_size opt , log_backup_number = opt_log_backup_number opt } logtype | not (opt_logging opt) = LogNone | debug = LogStdout logBufferSize | otherwise = LogFile logspec logBufferSize setHandlers :: Option -> Reporter -> Service -> LogRemover -> RouteDBRef -> IO () setHandlers opt rpt svc remover rdr = do setHandler sigStop stopHandler setHandler sigRetire retireHandler setHandler sigInfo infoHandler setHandler sigReload reloadHandler setHandler sigCHLD Ignore -- for CGI where stopHandler = Catch $ do report rpt "Mighty finished" finReporter rpt closeService svc remover exitImmediately ExitSuccess retireHandler = Catch $ do report rpt "Mighty retiring" closeService svc -- this lets warp break infoHandler = Catch $ report rpt "obsolted" reloadHandler = Catch $ do ifRouteFileIsValid rpt opt $ \newroute -> do writeRouteDBRef rdr newroute report rpt "Mighty reloaded" getTlsSetting :: Option -> IO TLSSettings getTlsSetting _opt = #ifdef HTTP_OVER_TLS case opt_service _opt of 0 -> return defaultTlsSettings -- this is dummy _ -> do cert <- BS.readFile $ opt_tls_cert_file _opt let strip = dropWhileEnd isSpace . dropWhile isSpace split "" = [] split s = case break (',' ==) s of ("",r) -> split (tail r) (s',"") -> [s'] (s',r) -> s' : split (tail r) chain_files = map strip $ split $ opt_tls_chain_files _opt chains <- mapM BS.readFile chain_files key <- BS.readFile $ opt_tls_key_file _opt return $ tlsSettingsChainMemory cert chains key #else return TLSSettings #endif ---------------------------------------------------------------- ifRouteFileIsValid :: Reporter -> Option -> (RouteDB -> IO ()) -> IO () ifRouteFileIsValid rpt opt act = case opt_routing_file opt of Nothing -> return () Just rfile -> try (parseRoute rfile defaultDomain defaultPort) >>= either reportError act where reportError = report rpt . BS.pack . ioeGetErrorString ---------------------------------------------------------------- mighty :: Option -> Reporter -> Service -> ApacheLogger -> ServerPushLogger -> ConnPool -> RouteDBRef -> TLSSettings -> IO () mighty opt rpt svc lgr pushlgr mgr rdr _tlsSetting = reportDo rpt $ case svc of HttpOnly s -> runSettingsSocket setting s app #ifdef HTTP_OVER_TLS HttpsOnly s -> runTLSSocket _tlsSetting setting s app HttpAndHttps s1 s2 -> void $ concurrently (runSettingsSocket setting s1 app) (runTLSSocket _tlsSetting setting s2 app) #else _ -> error "never reach" #endif where app = P.pushOnReferer P.defaultSettings (fileCgiApp cspec filespec cgispec revproxyspec rdr) debug = opt_debug_mode opt -- We don't use setInstallShutdownHandler because we may use -- two sockets for HTTP and HTTPS. setting = setPort (opt_port opt) -- just in case $ setHost (fromString (opt_host opt)) -- just in case $ setOnException (if debug then printStdout else warpHandler rpt) $ setTimeout (opt_connection_timeout opt) -- seconds $ setFdCacheDuration (opt_fd_cache_duration opt) $ setFileInfoCacheDuration 10 $ setServerName serverName $ setLogger lgr $ setServerPushLogger pushlgr defaultSettings serverName = BS.pack $ opt_server_name opt cspec = ClassicAppSpec { softwareName = serverName , statusFileDir = fromString $ opt_status_file_dir opt } filespec = FileAppSpec { indexFile = fromString $ opt_index_file opt , isHTML = \x -> ".html" `isSuffixOf` x || ".htm" `isSuffixOf` x } cgispec = CgiAppSpec { indexCgi = "index.cgi" } revproxyspec = RevProxyAppSpec { revProxyManager = mgr } ---------------------------------------------------------------- data Service = HttpOnly Socket | HttpsOnly Socket | HttpAndHttps Socket Socket ---------------------------------------------------------------- openService :: Option -> IO Service openService opt | service == 1 = do s <- bindPortTCP httpsPort hostpref debugMessage $ "HTTP/TLS service on port " ++ show httpsPort ++ "." return $ HttpsOnly s | service == 2 = do s1 <- bindPortTCP httpPort hostpref s2 <- bindPortTCP httpsPort hostpref debugMessage $ "HTTP service on port " ++ show httpPort ++ " and " ++ "HTTP/TLS service on port " ++ show httpsPort ++ "." return $ HttpAndHttps s1 s2 | otherwise = do s <- bindPortTCP httpPort hostpref debugMessage $ "HTTP service on port " ++ show httpPort ++ "." return $ HttpOnly s where httpPort = opt_port opt httpsPort = opt_tls_port opt hostpref = fromString $ opt_host opt service = opt_service opt debug = opt_debug_mode opt debugMessage msg = when debug $ do putStrLn msg hFlush stdout ---------------------------------------------------------------- closeService :: Service -> IO () closeService (HttpOnly s) = sClose s closeService (HttpsOnly s) = sClose s closeService (HttpAndHttps s1 s2) = sClose s1 >> sClose s2 ---------------------------------------------------------------- type ConnPool = H.Manager getManager :: Option -> IO ConnPool getManager opt = H.newManager H.defaultManagerSettings { H.managerConnCount = managerNumber , H.managerResponseTimeout = responseTimeout } where responseTimeout | opt_proxy_timeout opt == 0 = H.managerResponseTimeout H.defaultManagerSettings | otherwise = H.responseTimeoutMicro (opt_proxy_timeout opt * 1000000) -- micro seconds mighttpd2-3.4.1/src/WaiApp.hs0000644000000000000000000000565713052760261014132 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, CPP #-} module WaiApp (fileCgiApp) where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Network.HTTP.Types (preconditionFailed412, movedPermanently301, urlDecode, badRequest400) import Network.Wai (Application, responseLBS) import Network.Wai.Internal import Network.Wai.Application.Classic import Program.Mighty data Perhaps a = Found a | Redirect | Fail fileCgiApp :: ClassicAppSpec -> FileAppSpec -> CgiAppSpec -> RevProxyAppSpec -> RouteDBRef -> Application fileCgiApp cspec filespec cgispec revproxyspec rdr req respond | dotFile = do let st = badRequest400 fastResponse respond st defaultHeader "Bad Request\r\n" | otherwise = do um <- readRouteDBRef rdr case mmp um of Fail -> do let st = preconditionFailed412 fastResponse respond st defaultHeader "Precondition Failed\r\n" Redirect -> do let st = movedPermanently301 hdr = defaultHeader ++ redirectHeader req' fastResponse respond st hdr "Moved Permanently\r\n" Found (RouteFile src dst) -> fileApp cspec filespec (FileRoute src dst) req' respond Found (RouteRedirect src dst) -> redirectApp cspec (RedirectRoute src dst) req' respond Found (RouteCGI src dst) -> cgiApp cspec cgispec (CgiRoute src dst) req' respond Found (RouteRevProxy src dst dom prt) -> revProxyApp cspec revproxyspec (RevProxyRoute src dst dom prt) req respond where (host, _) = hostPort req rawpath = rawPathInfo req path = urlDecode False rawpath dotFile = BS.isPrefixOf "." rawpath || BS.isInfixOf "/." rawpath mmp um = case getBlock host um of Nothing -> Fail Just blk -> getRoute path blk fastResponse resp st hdr body = resp $ responseLBS st hdr body defaultHeader = [("Content-Type", "text/plain")] req' = req { rawPathInfo = path } -- FIXME getBlock :: ByteString -> RouteDB -> Maybe [Route] getBlock _ [] = Nothing getBlock key (Block doms maps : ms) | "*" `elem` doms = Just maps | key `elem` doms = Just maps | otherwise = getBlock key ms getRoute :: ByteString -> [Route] -> Perhaps Route getRoute _ [] = Fail getRoute key (m:ms) | src `isPrefixOf` key = Found m | src `isMountPointOf` key = Redirect | otherwise = getRoute key ms where src = routeSource m routeSource :: Route -> Src routeSource (RouteFile src _) = src routeSource (RouteRedirect src _) = src routeSource (RouteCGI src _) = src routeSource (RouteRevProxy src _ _ _) = src isPrefixOf :: Path -> ByteString -> Bool isPrefixOf src key = src `BS.isPrefixOf` key isMountPointOf :: Path -> ByteString -> Bool isMountPointOf src key = hasTrailingPathSeparator src && BS.length src - BS.length key == 1 && key `BS.isPrefixOf` src mighttpd2-3.4.1/test/0000755000000000000000000000000013052760261012570 5ustar0000000000000000mighttpd2-3.4.1/test/ConfigSpec.hs0000644000000000000000000000167413052760261015154 0ustar0000000000000000module ConfigSpec where import Program.Mighty import Test.Hspec spec :: Spec spec = do describe "parseConfig" $ do it "parses example.conf correctly" $ do res <- parseOption "conf/example.conf" "foo" res `shouldBe` ans ans :: Option ans = Option {opt_port = 80, opt_host = "*", opt_debug_mode = True, opt_user = "root", opt_group = "root", opt_pid_file = "/var/run/mighty.pid", opt_logging = True, opt_log_file = "/var/log/mighty", opt_log_file_size = 16777216, opt_log_backup_number = 10, opt_index_file = "index.html", opt_index_cgi = "index.cgi", opt_status_file_dir = "/usr/local/share/mighty/status", opt_connection_timeout = 30, opt_fd_cache_duration = 10, opt_server_name = "foo", opt_routing_file = Nothing, opt_tls_port = 443, opt_tls_cert_file = "cert.pem", opt_tls_chain_files = "chain.pem", opt_tls_key_file = "privkey.pem", opt_service = 0, opt_report_file = "/tmp/mighty_report", opt_proxy_timeout = 0} mighttpd2-3.4.1/test/RouteSpec.hs0000644000000000000000000000121213052760261015031 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module RouteSpec where import Test.Hspec import Program.Mighty spec :: Spec spec = do describe "parseRoute" $ do it "parses example.route correctly" $ do res <- parseRoute "conf/example.route" "localhost" 80 res `shouldBe` ans ans :: [Block] ans = [Block ["localhost","www.example.com"] [RouteCGI "/~alice/cgi-bin/" "/home/alice/public_html/cgi-bin/",RouteFile "/~alice/" "/home/alice/public_html/",RouteCGI "/cgi-bin/" "/export/cgi-bin/",RouteRevProxy "/app/cal/" "/calendar/" "example.net" 80,RouteRevProxy "/app/wiki/" "/" "127.0.0.1" 3000,RouteFile "/" "/export/www/"]] mighttpd2-3.4.1/test/Spec.hs0000644000000000000000000000005413052760261014015 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} mighttpd2-3.4.1/utils/0000755000000000000000000000000013052760261012751 5ustar0000000000000000mighttpd2-3.4.1/utils/mightyctl.hs0000644000000000000000000000320213052760261015306 0ustar0000000000000000module Main where import Data.List import System.Environment import System.Exit import System.Posix.Signals import System.Posix.Types import Program.Mighty (getMightyPid, sigStop, sigReload, sigRetire, sigInfo) commandDB :: [(String, Signal)] commandDB = [ ("stop", sigStop) , ("reload", sigReload) , ("retire", sigRetire) , ("info", sigInfo) ] usage :: IO a usage = do putStrLn "Usage:" putStrLn $ " mightyctl " ++ cmds ++ " [pid]" exitFailure where cmds = intercalate "|" $ map fst commandDB main :: IO () main = do (sig,mpid) <- getArgs >>= checkArgs pid <- maybe getProcessIdWithPS return mpid signalProcess sig pid checkArgs :: [String] -> IO (Signal, Maybe ProcessID) checkArgs [cmd] = do sig <- getSignal cmd return (sig, Nothing) checkArgs [cmd,num] = do sig <- getSignal cmd pid <- getProcessId num return (sig, Just pid) checkArgs _ = usage getSignal :: String -> IO Signal getSignal cmd = check $ lookup cmd commandDB where check (Just sig) = return sig check Nothing = do putStrLn $ "No such command: " ++ cmd usage getProcessId :: String -> IO ProcessID getProcessId num = check $ reads num where check [(pid,"")] = return . fromIntegral $ (pid :: Int) check _ = do putStrLn $ "No such process id: " ++ num usage getProcessIdWithPS :: IO ProcessID getProcessIdWithPS = getMightyPid >>= check where check [] = putStrLn "No Mighty found" >> usage check [pid] = return pid check pids = do putStrLn $ "Multiple Mighty found: " ++ intercalate ", " (map show pids) usage mighttpd2-3.4.1/utils/mkindex.hs0000644000000000000000000000504513052760261014750 0ustar0000000000000000{-# LANGUAGE CPP #-} -- mkindex :: Making index.html for the current directory. #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif import Data.Bits import Data.Time (formatTime) import Data.Time.Clock.POSIX import System.Directory import System.Posix.Files import Text.Printf #if MIN_VERSION_time(1,5,0) import Data.Time (defaultTimeLocale) #else import System.Locale (defaultTimeLocale) #endif indexFile :: String indexFile = "index.html" main :: IO () main = do contents <- mkContents writeFile indexFile $ header ++ contents ++ tailer setFileMode indexFile mode where mode = ownerReadMode .|. ownerWriteMode .|. groupReadMode .|. otherReadMode mkContents :: IO String mkContents = do fileNames <- filter dotAndIndex <$> getDirectoryContents "." stats <- mapM getFileStatus fileNames let fmsls = zipWith pp fileNames stats maxLen = maximum $ map (\(_,_,_,x) -> x) fmsls contents = concatMap (content maxLen) fmsls return contents where dotAndIndex x = head x /= '.' && x /= indexFile pp :: String -> FileStatus -> (String,String,String,Int) pp f st = (file,mtime,size,flen) where file = ppFile f st flen = length file mtime = ppMtime st size = ppSize st ppFile :: String -> FileStatus -> String ppFile f st | isDirectory st = f ++ "/" | otherwise = f ppMtime :: FileStatus -> String ppMtime st = dateFormat . epochTimeToUTCTime $ st where epochTimeToUTCTime = posixSecondsToUTCTime . realToFrac . modificationTime dateFormat = formatTime defaultTimeLocale "%d-%b-%Y %H:%M" ppSize :: FileStatus -> String ppSize st | isDirectory st = " - " | otherwise = sizeFormat . fromIntegral . fileSize $ st where sizeFormat siz = unit siz " KMGT" unit _ [] = error "unit" unit s [u] = format s u unit s (u:us) | s >= 1024 = unit (s `div` 1024) us | otherwise = format s u format :: Integer -> Char -> String format = printf "%3d%c" header :: String header = "\ \n\ \n\ \n\ \n\ Directory contents\n\ \n\

Directory contents

\n\
\n\ 
\n"

content :: Int -> (String,String,String,Int) -> String
content lim (f,m,s,len) = "" ++ f ++ "  " ++ replicate (lim - len) ' ' ++ m ++ "  " ++ s ++ "\n"

tailer :: String
tailer = "\
\n\
\n\ \n\ \n"