-- | GF server mode
{-# LANGUAGE CPP #-}
module GF.Server(server) where
import Data.List(partition,stripPrefix,isInfixOf)
import qualified Data.Map as M
import Control.Applicative -- for GHC<7.10
import Control.Monad(when)
import Control.Monad.State(StateT(..),get,gets,put)
import Control.Monad.Except(ExceptT(..),runExceptT)
import System.Random(randomRIO)
--import System.IO(stderr,hPutStrLn)
import GF.System.Catch(try)
import Control.Exception(bracket_)
import System.IO.Error(isAlreadyExistsError)
import GF.System.Directory(doesDirectoryExist,doesFileExist,createDirectory,
                           setCurrentDirectory,getCurrentDirectory,
                           getDirectoryContents,removeFile,removeDirectory,
                           getModificationTime)
import Data.Time (getCurrentTime,formatTime)
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format(defaultTimeLocale,rfc822DateFormat)
#else
import System.Locale(defaultTimeLocale,rfc822DateFormat)
#endif
import System.FilePath(dropExtension,takeExtension,takeFileName,takeDirectory,
                       (</>),makeRelative)
#ifndef mingw32_HOST_OS
import System.Posix.Files(getSymbolicLinkStatus,isSymbolicLink,removeLink,
                          createSymbolicLink)
#endif
import GF.Infra.Concurrency(newMVar,modifyMVar,newLog)
import Network.URI(URI(..))
import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache)
--import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi
import Network.CGI(handleErrors,liftIO)
import CGIUtils(handleCGIErrors)--,outputJSONP,stderrToFile
import Text.JSON(JSValue(..),Result(..),valFromObj,encode,decode,showJSON,makeObj)
--import System.IO.Silently(hCapture)
import System.Process(readProcessWithExitCode)
import System.Exit(ExitCode(..))
import Codec.Binary.UTF8.String(decodeString,encodeString)
import GF.Infra.UseIO(readBinaryFile,writeBinaryFile,ePutStrLn)
import GF.Infra.SIO(captureSIO)
import GF.Data.Utilities(apSnd,mapSnd)
import qualified PGFService as PS
import qualified ExampleService as ES
import Data.Version(showVersion)
import Paths_gf(getDataDir,version)
import GF.Infra.BuildInfo (buildInfo)
import SimpleEditor.Convert(parseModule)
import RunHTTP(cgiHandler)
import URLEncoding(decodeQuery)

--logFile :: FilePath
--logFile = "pgf-error.log"

debug :: String -> m ()
debug String
s = String -> m ()
forall (m :: * -> *). Output m => String -> m ()
logPutStrLn String
s

-- | Combined FastCGI and HTTP server
server :: p
-> Int
-> Maybe String
-> (a -> String -> SIO (Maybe a))
-> a
-> IO ()
server p
jobs Int
port Maybe String
optroot a -> String -> SIO (Maybe a)
execute1 a
state0 =
  do --stderrToFile logFile
     MVar (Map String a)
state <- Map String a -> IO (MVar (Map String a))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Map String a
forall k a. Map k a
M.empty
     Caches
cache <- p -> IO Caches
forall p. p -> IO Caches
PS.newPGFCache p
jobs
     String
datadir <- IO String
getDataDir
     let root :: String
root = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String
datadirString -> String -> String
</>String
"www") String -> String
forall a. a -> a
id Maybe String
optroot
--   debug $ "document root="++root
     String -> IO ()
setDir String
root
--   FCGI.acceptLoop forkIO (handle_fcgi execute1 state0 state cache)
     -- if acceptLoop returns, then GF was not invoked as a FastCGI script
     (a -> String -> SIO (Maybe a))
-> a -> MVar (Map String a) -> Caches -> String -> IO ()
forall a.
(a -> String -> SIO (Maybe a))
-> a -> MVar (Map String a) -> Caches -> String -> IO ()
http_server a -> String -> SIO (Maybe a)
execute1 a
state0 MVar (Map String a)
state Caches
cache String
root
  where
    -- | HTTP server
    http_server :: (a -> String -> SIO (Maybe a))
-> a -> MVar (Map String a) -> Caches -> String -> IO ()
http_server a -> String -> SIO (Maybe a)
execute1 a
state0 MVar (Map String a)
state Caches
cache String
root =
      do String -> IO ()
logLn <- (String -> IO ()) -> IO (String -> IO ())
forall (m1 :: * -> *) (m2 :: * -> *) a b.
(MonadIO m1, MonadIO m2) =>
(a -> IO b) -> m1 (a -> m2 ())
newLog String -> IO ()
forall (m :: * -> *). Output m => String -> m ()
ePutStrLn -- to avoid intertwined log messages
         String -> IO ()
logLn String
gf_version
         String -> IO ()
logLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Document root = "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
root
         String -> IO ()
logLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Starting HTTP server, open http://localhost:"
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
portString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"/ in your web browser."
         Int -> (Request -> IO Response) -> IO ()
initServer Int
port ((String -> IO ())
-> String
-> a
-> Caches
-> (a -> String -> SIO (Maybe a))
-> MVar (Map String a)
-> Request
-> IO Response
forall a a.
(String -> IO a)
-> String
-> a
-> Caches
-> (a -> String -> SIO (Maybe a))
-> MVar (Map String a)
-> Request
-> IO Response
handle String -> IO ()
logLn String
root a
state0 Caches
cache a -> String -> SIO (Maybe a)
execute1 MVar (Map String a)
state)

gf_version :: String
gf_version = String
"This is GF version "String -> String -> String
forall a. [a] -> [a] -> [a]
++Version -> String
showVersion Version
versionString -> String -> String
forall a. [a] -> [a] -> [a]
++String
".\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
buildInfo

{-
-- | FastCGI request handler
handle_fcgi execute1 state0 stateM cache =
  do Just method <- FCGI.getRequestMethod
     debug $ "request method="++method
     Just path <- FCGI.getPathInfo
--   debug $ "path info="++path
     query <- maybe (return "") return =<< FCGI.getQueryString
--   debug $ "query string="++query
     let uri = URI "" Nothing path query ""
     headers <- fmap (mapFst show) FCGI.getAllRequestHeaders
     body <- fmap BS.unpack FCGI.fGetContents
     let req = Request method uri headers body
--   debug (show req)
     (output,resp) <- liftIO $ hCapture [stdout] $ modifyMVar stateM $ handle state0 cache execute1 req
     let Response code headers body = resp
--   debug output
     debug $ "    "++show code++" "++show headers
     FCGI.setResponseStatus code
     mapM_ (uncurry (FCGI.setResponseHeader . toHeader)) headers
     let pbody = BS.pack body
         n = BS.length pbody
     FCGI.fPut pbody
     debug $ "done "++show n
-}

-- * Request handler
-- | Handler monad
type HM s a = StateT (Q,s) (ExceptT Response IO) a
run :: HM s Response -> (Q,s) -> IO (s,Response)
run :: HM s Response -> (Q, s) -> IO (s, Response)
run HM s Response
m (Q, s)
s = (Response -> IO (s, Response))
-> ((Response, (Q, s)) -> IO (s, Response))
-> Either Response (Response, (Q, s))
-> IO (s, Response)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Response -> IO (s, Response)
forall (m :: * -> *) b. Monad m => b -> m (s, b)
bad (Response, (Q, s)) -> IO (s, Response)
forall (m :: * -> *) b a a. Monad m => (b, (a, a)) -> m (a, b)
ok (Either Response (Response, (Q, s)) -> IO (s, Response))
-> IO (Either Response (Response, (Q, s))) -> IO (s, Response)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT Response IO (Response, (Q, s))
-> IO (Either Response (Response, (Q, s)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (HM s Response -> (Q, s) -> ExceptT Response IO (Response, (Q, s))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT HM s Response
m (Q, s)
s)
  where
    bad :: b -> m (s, b)
bad b
resp = (s, b) -> m (s, b)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Q, s) -> s
forall a b. (a, b) -> b
snd (Q, s)
s,b
resp)
    ok :: (b, (a, a)) -> m (a, b)
ok (b
resp,(a
qs,a
state)) = (a, b) -> m (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
state,b
resp)

get_qs :: HM s Q
get_qs :: HM s Q
get_qs = ((Q, s) -> Q) -> HM s Q
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Q, s) -> Q
forall a b. (a, b) -> a
fst
get_state :: HM s s
get_state :: HM s s
get_state = ((Q, s) -> s) -> HM s s
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Q, s) -> s
forall a b. (a, b) -> b
snd
put_qs :: Q -> StateT (Q, b) (ExceptT Response IO) ()
put_qs Q
qs = do b
state <- HM b b
forall s. HM s s
get_state; (Q, b) -> StateT (Q, b) (ExceptT Response IO) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Q
qs,b
state)
put_state :: b -> StateT (Q, b) (ExceptT Response IO) ()
put_state b
state = do Q
qs <- HM b Q
forall s. HM s Q
get_qs; (Q, b) -> StateT (Q, b) (ExceptT Response IO) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Q
qs,b
state)

err :: Response -> HM s a
err :: Response -> HM s a
err Response
e = ((Q, s) -> ExceptT Response IO (a, (Q, s))) -> HM s a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT (((Q, s) -> ExceptT Response IO (a, (Q, s))) -> HM s a)
-> ((Q, s) -> ExceptT Response IO (a, (Q, s))) -> HM s a
forall a b. (a -> b) -> a -> b
$ \ (Q, s)
s -> IO (Either Response (a, (Q, s))) -> ExceptT Response IO (a, (Q, s))
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Response (a, (Q, s)))
 -> ExceptT Response IO (a, (Q, s)))
-> IO (Either Response (a, (Q, s)))
-> ExceptT Response IO (a, (Q, s))
forall a b. (a -> b) -> a -> b
$ Either Response (a, (Q, s)) -> IO (Either Response (a, (Q, s)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Response (a, (Q, s)) -> IO (Either Response (a, (Q, s))))
-> Either Response (a, (Q, s)) -> IO (Either Response (a, (Q, s)))
forall a b. (a -> b) -> a -> b
$ Response -> Either Response (a, (Q, s))
forall a b. a -> Either a b
Left Response
e

hmbracket_ :: IO () -> IO () -> HM s a -> HM s a
hmbracket_ :: IO () -> IO () -> HM s a -> HM s a
hmbracket_ IO ()
pre IO ()
post HM s a
m =
    do (Q, s)
s <- StateT (Q, s) (ExceptT Response IO) (Q, s)
forall s (m :: * -> *). MonadState s m => m s
get
       Either Response (a, (Q, s))
e <- IO (Either Response (a, (Q, s)))
-> StateT
     (Q, s) (ExceptT Response IO) (Either Response (a, (Q, s)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Response (a, (Q, s)))
 -> StateT
      (Q, s) (ExceptT Response IO) (Either Response (a, (Q, s))))
-> IO (Either Response (a, (Q, s)))
-> StateT
     (Q, s) (ExceptT Response IO) (Either Response (a, (Q, s)))
forall a b. (a -> b) -> a -> b
$ IO ()
-> IO ()
-> IO (Either Response (a, (Q, s)))
-> IO (Either Response (a, (Q, s)))
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ IO ()
pre IO ()
post (IO (Either Response (a, (Q, s)))
 -> IO (Either Response (a, (Q, s))))
-> IO (Either Response (a, (Q, s)))
-> IO (Either Response (a, (Q, s)))
forall a b. (a -> b) -> a -> b
$ ExceptT Response IO (a, (Q, s)) -> IO (Either Response (a, (Q, s)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Response IO (a, (Q, s))
 -> IO (Either Response (a, (Q, s))))
-> ExceptT Response IO (a, (Q, s))
-> IO (Either Response (a, (Q, s)))
forall a b. (a -> b) -> a -> b
$ HM s a -> (Q, s) -> ExceptT Response IO (a, (Q, s))
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT HM s a
m (Q, s)
s
       case Either Response (a, (Q, s))
e of
         Left Response
resp -> Response -> HM s a
forall s a. Response -> HM s a
err Response
resp
         Right (a
a,(Q, s)
s) -> do (Q, s) -> StateT (Q, s) (ExceptT Response IO) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Q, s)
s;a -> HM s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | HTTP request handler
handle :: (String -> IO a)
-> String
-> a
-> Caches
-> (a -> String -> SIO (Maybe a))
-> MVar (Map String a)
-> Request
-> IO Response
handle String -> IO a
logLn String
documentroot a
state0 Caches
cache a -> String -> SIO (Maybe a)
execute1 MVar (Map String a)
stateVar
       rq :: Request
rq@(Request String
method URI{uriPath :: URI -> String
uriPath=String
upath,uriQuery :: URI -> String
uriQuery=String
q} [(String, String)]
hdrs String
body) =
    IO Response -> IO Response
addDate (IO Response -> IO Response) -> IO Response -> IO Response
forall a b. (a -> b) -> a -> b
$
    case String
method of
      String
"POST" -> Q -> IO Response
normal_request (String -> Q
utf8inputs String
body)
      String
"GET"  -> Q -> IO Response
normal_request (String -> Q
utf8inputs String
q)
      String
_ -> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Response
resp501 (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
"method "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
method)
  where
    logPutStrLn :: String -> m a
logPutStrLn String
msg = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ String -> IO a
logLn String
msg
--  debug msg = logPutStrLn msg

    addDate :: IO Response -> IO Response
addDate IO Response
m =
      do UTCTime
t <- IO UTCTime
getCurrentTime
         Response
r <- IO Response
m
         let fmt :: String
fmt = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
rfc822DateFormat UTCTime
t
         Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
r{resHeaders :: [(String, String)]
resHeaders=(String
"Date",String
fmt)(String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:Response -> [(String, String)]
resHeaders Response
r}

    normal_request :: Q -> IO Response
normal_request Q
qs =
      do String -> IO a
forall (m :: * -> *). MonadIO m => String -> m a
logPutStrLn (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
methodString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
upathString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" "String -> String -> String
forall a. [a] -> [a] -> [a]
++[(String, String)] -> String
forall a. Show a => a -> String
show (((String, String) -> String) -> Q -> [(String, String)]
forall b b' a. (b -> b') -> [(a, b)] -> [(a, b')]
mapSnd (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
500(String -> String)
-> ((String, String) -> String) -> (String, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(String, String) -> String
forall a b. (a, b) -> a
fst) Q
qs)
         let stateful :: HM (Map String a) Response -> IO Response
stateful HM (Map String a) Response
m = MVar (Map String a)
-> (Map String a -> IO (Map String a, Response)) -> IO Response
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Map String a)
stateVar ((Map String a -> IO (Map String a, Response)) -> IO Response)
-> (Map String a -> IO (Map String a, Response)) -> IO Response
forall a b. (a -> b) -> a -> b
$ \ Map String a
s -> HM (Map String a) Response
-> (Q, Map String a) -> IO (Map String a, Response)
forall s. HM s Response -> (Q, s) -> IO (s, Response)
run HM (Map String a) Response
m (Q
qs,Map String a
s)
          -- stateful ensures mutual exclusion, so you can use/change the cwd
         case String
upath of
           String
"/new"     -> HM (Map String a) Response -> IO Response
stateful (HM (Map String a) Response -> IO Response)
-> HM (Map String a) Response -> IO Response
forall a b. (a -> b) -> a -> b
$ HM (Map String a) Response
new
           String
"/gfshell" -> HM (Map String a) Response -> IO Response
stateful (HM (Map String a) Response -> IO Response)
-> HM (Map String a) Response -> IO Response
forall a b. (a -> b) -> a -> b
$ (String -> HM (Map String a) Response)
-> HM (Map String a) Response
forall s b. (String -> HM s b) -> HM s b
inDir String -> HM (Map String a) Response
forall k.
Ord k =>
k -> StateT (Q, Map k a) (ExceptT Response IO) Response
command
           String
"/cloud"   -> HM (Map String a) Response -> IO Response
stateful (HM (Map String a) Response -> IO Response)
-> HM (Map String a) Response -> IO Response
forall a b. (a -> b) -> a -> b
$ (String -> HM (Map String a) Response)
-> HM (Map String a) Response
forall s b. (String -> HM s b) -> HM s b
inDir String -> HM (Map String a) Response
cloud
--         "/stop"    ->
--         "/start"   ->
           String
"/parse"   -> [(String, String)] -> IO Response
forall (m :: * -> *). Monad m => [(String, String)] -> m Response
parse (Q -> [(String, String)]
forall a b' b. [(a, (b', b))] -> [(a, b')]
decoded Q
qs)
           String
"/version" -> ([(String, UTCTime)], [(String, UTCTime)]) -> Response
forall a a.
(Show a, Show a) =>
([(String, a)], [(String, a)]) -> Response
versionInfo (([(String, UTCTime)], [(String, UTCTime)]) -> Response)
-> IO ([(String, UTCTime)], [(String, UTCTime)]) -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Caches -> IO ([(String, UTCTime)], [(String, UTCTime)])
PS.listPGFCache Caches
cache
           String
"/flush"   -> do Caches -> IO ()
PS.flushPGFCache Caches
cache; Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Response
ok200 String
"flushed")
           Char
'/':String
rpath ->
             -- This code runs without mutual exclusion, so it must *not*
             -- use/change the cwd. Access files by absolute paths only.
             case (String -> String
takeDirectory String
path,String -> String
takeFileName String
path,String -> String
takeExtension String
path) of
               (String
_  ,String
_             ,String
".pgf") -> do --debug $ "PGF service: "++path
                                                 CGI CGIResult -> IO Response
wrapCGI (CGI CGIResult -> IO Response) -> CGI CGIResult -> IO Response
forall a b. (a -> b) -> a -> b
$ Caches -> String -> CGI CGIResult
PS.cgiMain' Caches
cache String
path
               (String
dir,String
"grammars.cgi",String
_     ) -> String -> [(String, String)] -> IO Response
forall (m :: * -> *).
MonadIO m =>
String -> [(String, String)] -> m Response
grammarList String
dir (Q -> [(String, String)]
forall a b' b. [(a, (b', b))] -> [(a, b')]
decoded Q
qs)
               (String
dir  ,String
"exb.fcgi"  ,String
_    ) -> CGI CGIResult -> IO Response
wrapCGI (CGI CGIResult -> IO Response) -> CGI CGIResult -> IO Response
forall a b. (a -> b) -> a -> b
$ String -> String -> Cache PGF -> CGI CGIResult
ES.cgiMain' String
root String
dir (Caches -> Cache PGF
PS.pgfCache Caches
cache)
               (String, String, String)
_ -> String -> String -> IO Response
serveStaticFile String
rpath String
path
             where path :: String
path = String -> String
translatePath String
rpath
           String
_ -> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ String -> Response
resp400 String
upath

    root :: String
root = String
documentroot

    translatePath :: String -> String
translatePath String
rpath = String
rootString -> String -> String
</>String
rpath -- hmm, check for ".."

    versionInfo :: ([(String, a)], [(String, a)]) -> Response
versionInfo ([(String, a)]
c1,[(String, a)]
c2) =
        String -> Response
html200 (String -> Response)
-> ([String] -> String) -> [String] -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> Response) -> [String] -> Response
forall a b. (a -> b) -> a -> b
$
           String
"<!DOCTYPE html>"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
           String
"<meta name = \"viewport\" content = \"width = device-width\">"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
           String
"<link rel=\"stylesheet\" type=\"text/css\" href=\"cloud.css\" title=\"Cloud\">"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
           String
""String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
           (String
"<h2>"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
hdrString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"</h2>")String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
           ((String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> String -> String
forall a. [a] -> [a] -> [a]
(++) (String
"<p>"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String -> [String]
forall a. a -> [a]
repeat String
"<br>") [String]
buildinfo)[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
           String -> [(String, a)] -> [String]
forall a. Show a => String -> [(String, a)] -> [String]
sh String
"Haskell run-time system" [(String, a)]
c1[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
           String -> [(String, a)] -> [String]
forall a. Show a => String -> [(String, a)] -> [String]
sh String
"C run-time system" [(String, a)]
c2
      where
        String
hdr:[String]
buildinfo = String -> [String]
lines String
gf_version
        rel :: String -> String
rel = String -> String -> String
makeRelative String
documentroot
        sh1 :: (String, a) -> String
sh1 (String
path,a
t) = String
"<tr><td>"String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
rel String
pathString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"<td>"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
t
        sh :: String -> [(String, a)] -> [String]
sh String
_ [] = []
        sh String
hdr [(String, a)]
gs =
                String
""String -> [String] -> [String]
forall a. a -> [a] -> [a]
:(String
"<h3>"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
hdrString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"</h3>")String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                String
"<table class=loaded_grammars><tr><th>Grammar<th>Last modified"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                ((String, a) -> String) -> [(String, a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, a) -> String
forall a. Show a => (String, a) -> String
sh1 [(String, a)]
gs[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                [String
"</table>"]

    wrapCGI :: CGI CGIResult -> IO Response
wrapCGI CGI CGIResult
cgi = String -> CGI CGIResult -> Request -> IO Response
forall (f :: * -> *).
Monad f =>
String -> CGIT f CGIResult -> Request -> f Response
cgiHandler String
root (CGI CGIResult -> CGI CGIResult
forall (m :: * -> *).
(MonadCGI m, MonadCatch m, MonadIO m) =>
m CGIResult -> m CGIResult
handleErrors (CGI CGIResult -> CGI CGIResult)
-> (CGI CGIResult -> CGI CGIResult)
-> CGI CGIResult
-> CGI CGIResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CGI CGIResult -> CGI CGIResult
handleCGIErrors (CGI CGIResult -> CGI CGIResult) -> CGI CGIResult -> CGI CGIResult
forall a b. (a -> b) -> a -> b
$ CGI CGIResult
cgi) Request
rq

    look :: String -> StateT (Q, s) (ExceptT Response IO) String
look String
field =
      do Q
qs <- HM s Q
forall s. HM s Q
get_qs
         case ((String, (String, String)) -> Bool) -> Q -> (Q, Q)
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
field)(String -> Bool)
-> ((String, (String, String)) -> String)
-> (String, (String, String))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(String, (String, String)) -> String
forall a b. (a, b) -> a
fst) Q
qs of
           ((String
_,(String
value,String
_)):Q
qs1,Q
qs2) -> do Q -> StateT (Q, s) (ExceptT Response IO) ()
forall b. Q -> StateT (Q, b) (ExceptT Response IO) ()
put_qs (Q
qs1Q -> Q -> Q
forall a. [a] -> [a] -> [a]
++Q
qs2)
                                         String -> StateT (Q, s) (ExceptT Response IO) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
value
           (Q, Q)
_ -> Response -> StateT (Q, s) (ExceptT Response IO) String
forall s a. Response -> HM s a
err (Response -> StateT (Q, s) (ExceptT Response IO) String)
-> Response -> StateT (Q, s) (ExceptT Response IO) String
forall a b. (a -> b) -> a -> b
$ String -> Response
resp400 (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
"no "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
fieldString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" in request"
    
    inDir :: (String -> HM s b) -> HM s b
inDir String -> HM s b
ok = String -> HM s b
cd (String -> HM s b)
-> StateT (Q, s) (ExceptT Response IO) String -> HM s b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> StateT (Q, s) (ExceptT Response IO) String
forall s. String -> StateT (Q, s) (ExceptT Response IO) String
look String
"dir"
      where
        cd :: String -> HM s b
cd (Char
'/':dir :: String
dir@(Char
't':Char
'm':Char
'p':String
_)) =
          do String
cwd <- StateT (Q, s) (ExceptT Response IO) String
forall (io :: * -> *). MonadIO io => io String
getCurrentDirectory
             Bool
b <- String -> StateT (Q, s) (ExceptT Response IO) Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesDirectoryExist String
dir
             case Bool
b of
               Bool
False  -> do Either IOError String
b <- IO (Either IOError String)
-> StateT (Q, s) (ExceptT Response IO) (Either IOError String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOError String)
 -> StateT (Q, s) (ExceptT Response IO) (Either IOError String))
-> IO (Either IOError String)
-> StateT (Q, s) (ExceptT Response IO) (Either IOError String)
forall a b. (a -> b) -> a -> b
$ IO String -> IO (Either IOError String)
forall a. IO a -> IO (Either IOError a)
try (IO String -> IO (Either IOError String))
-> IO String -> IO (Either IOError String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
dir -- poor man's symbolic links
                            case Either IOError String
b of
                              Left IOError
_ -> Response -> HM s b
forall s a. Response -> HM s a
err (Response -> HM s b) -> Response -> HM s b
forall a b. (a -> b) -> a -> b
$ String -> Response
resp404 String
dir
                              Right String
dir' -> String -> HM s b
cd String
dir'
               Bool
True  -> do --logPutStrLn $ "cd "++dir
                           String -> HM s b -> HM s b
forall s a. String -> HM s a -> HM s a
hmInDir String
dir (String -> HM s b
ok String
dir)
        cd String
dir = Response -> HM s b
forall s a. Response -> HM s a
err (Response -> HM s b) -> Response -> HM s b
forall a b. (a -> b) -> a -> b
$ String -> Response
resp400 (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
"unacceptable directory "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
dir

    -- First ensure that only one thread that depends on the cwd is running!
    hmInDir :: String -> HM s a -> HM s a
hmInDir String
dir = IO () -> IO () -> HM s a -> HM s a
forall s a. IO () -> IO () -> HM s a -> HM s a
hmbracket_ (String -> IO ()
setDir String
dir) (String -> IO ()
setDir String
documentroot)

    new :: HM (Map String a) Response
new = (String -> Response)
-> StateT (Q, Map String a) (ExceptT Response IO) String
-> HM (Map String a) Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Response
ok200 (StateT (Q, Map String a) (ExceptT Response IO) String
 -> HM (Map String a) Response)
-> StateT (Q, Map String a) (ExceptT Response IO) String
-> HM (Map String a) Response
forall a b. (a -> b) -> a -> b
$ IO String -> StateT (Q, Map String a) (ExceptT Response IO) String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String
 -> StateT (Q, Map String a) (ExceptT Response IO) String)
-> IO String
-> StateT (Q, Map String a) (ExceptT Response IO) String
forall a b. (a -> b) -> a -> b
$ IO String
newDirectory

    command :: k -> StateT (Q, Map k a) (ExceptT Response IO) Response
command k
dir =
      do String
cmd <- String -> StateT (Q, Map k a) (ExceptT Response IO) String
forall s. String -> StateT (Q, s) (ExceptT Response IO) String
look String
"command"
         Map k a
state <- HM (Map k a) (Map k a)
forall s. HM s s
get_state
         let st :: a
st = a -> (a -> a) -> Maybe a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
state0 a -> a
forall a. a -> a
id (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
dir Map k a
state
         (String
output,Maybe a
st') <- IO (String, Maybe a)
-> StateT (Q, Map k a) (ExceptT Response IO) (String, Maybe a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (String, Maybe a)
 -> StateT (Q, Map k a) (ExceptT Response IO) (String, Maybe a))
-> IO (String, Maybe a)
-> StateT (Q, Map k a) (ExceptT Response IO) (String, Maybe a)
forall a b. (a -> b) -> a -> b
$ SIO (Maybe a) -> IO (String, Maybe a)
forall a. SIO a -> IO (String, a)
captureSIO (SIO (Maybe a) -> IO (String, Maybe a))
-> SIO (Maybe a) -> IO (String, Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> String -> SIO (Maybe a)
execute1 a
st String
cmd
         let state' :: Map k a
state' = Map k a -> (a -> Map k a) -> Maybe a -> Map k a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map k a
state ((a -> Map k a -> Map k a) -> Map k a -> a -> Map k a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
dir) Map k a
state) Maybe a
st'
         Map k a -> StateT (Q, Map k a) (ExceptT Response IO) ()
forall b. b -> StateT (Q, b) (ExceptT Response IO) ()
put_state Map k a
state'
         Response -> StateT (Q, Map k a) (ExceptT Response IO) Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> StateT (Q, Map k a) (ExceptT Response IO) Response)
-> Response -> StateT (Q, Map k a) (ExceptT Response IO) Response
forall a b. (a -> b) -> a -> b
$ String -> Response
ok200 String
output

    parse :: [(String, String)] -> m Response
parse [(String, String)]
qs = Response -> m Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ JSValue -> Response
forall a. JSON a => a -> Response
json200 ([(String, JSValue)] -> JSValue
makeObj(((String, String) -> (String, JSValue))
-> [(String, String)] -> [(String, JSValue)]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> (String, JSValue)
forall a2. (a2, String) -> (a2, JSValue)
parseModule [(String, String)]
qs))

    cloud :: String -> HM (Map String a) Response
cloud String
dir =
      do String
cmd <- String -> StateT (Q, Map String a) (ExceptT Response IO) String
forall s. String -> StateT (Q, s) (ExceptT Response IO) String
look String
"command"
         case String
cmd of
           String
"make" -> ([(String, String)] -> [(String, String)])
-> String -> [(String, String)] -> HM (Map String a) Response
forall (t :: * -> *) s.
Foldable t =>
([(String, String)] -> t (String, String))
-> String
-> [(String, String)]
-> StateT (Q, s) (ExceptT Response IO) Response
make [(String, String)] -> [(String, String)]
forall a. a -> a
id String
dir ([(String, String)] -> HM (Map String a) Response)
-> (Q -> [(String, String)]) -> Q -> HM (Map String a) Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q -> [(String, String)]
forall a a b'. [(a, (a, b'))] -> [(a, b')]
raw (Q -> HM (Map String a) Response)
-> StateT (Q, Map String a) (ExceptT Response IO) Q
-> HM (Map String a) Response
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (Q, Map String a) (ExceptT Response IO) Q
forall s. HM s Q
get_qs
           String
"remake" -> ([(String, String)] -> [(String, String)])
-> String -> [(String, String)] -> HM (Map String a) Response
forall (t :: * -> *) s.
Foldable t =>
([(String, String)] -> t (String, String))
-> String
-> [(String, String)]
-> StateT (Q, s) (ExceptT Response IO) Response
make [(String, String)] -> [(String, String)]
forall a a. [(a, [a])] -> [(a, [a])]
skip_empty String
dir ([(String, String)] -> HM (Map String a) Response)
-> (Q -> [(String, String)]) -> Q -> HM (Map String a) Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q -> [(String, String)]
forall a a b'. [(a, (a, b'))] -> [(a, b')]
raw (Q -> HM (Map String a) Response)
-> StateT (Q, Map String a) (ExceptT Response IO) Q
-> HM (Map String a) Response
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (Q, Map String a) (ExceptT Response IO) Q
forall s. HM s Q
get_qs
           String
"upload" -> ([(String, String)] -> [(String, String)])
-> [(String, String)] -> HM (Map String a) Response
forall (t :: * -> *) b s.
Foldable t =>
([(String, b)] -> t (String, String))
-> [(String, b)] -> StateT (Q, s) (ExceptT Response IO) Response
upload [(String, String)] -> [(String, String)]
forall a. a -> a
id ([(String, String)] -> HM (Map String a) Response)
-> (Q -> [(String, String)]) -> Q -> HM (Map String a) Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q -> [(String, String)]
forall a a b'. [(a, (a, b'))] -> [(a, b')]
raw (Q -> HM (Map String a) Response)
-> StateT (Q, Map String a) (ExceptT Response IO) Q
-> HM (Map String a) Response
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (Q, Map String a) (ExceptT Response IO) Q
forall s. HM s Q
get_qs
           String
"ls" -> String -> HM (Map String a) Response
jsonList (String -> HM (Map String a) Response)
-> (Q -> String) -> Q -> HM (Map String a) Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> ((String, String) -> String) -> Maybe (String, String) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
".json" (String, String) -> String
forall a b. (a, b) -> a
fst (Maybe (String, String) -> String)
-> (Q -> Maybe (String, String)) -> Q -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q -> Maybe (String, String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"ext" (Q -> HM (Map String a) Response)
-> StateT (Q, Map String a) (ExceptT Response IO) Q
-> HM (Map String a) Response
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (Q, Map String a) (ExceptT Response IO) Q
forall s. HM s Q
get_qs
           String
"ls-l" -> String -> HM (Map String a) Response
forall (f :: * -> *). MonadIO f => String -> f Response
jsonListLong (String -> HM (Map String a) Response)
-> (Q -> String) -> Q -> HM (Map String a) Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> ((String, String) -> String) -> Maybe (String, String) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
".json" (String, String) -> String
forall a b. (a, b) -> a
fst (Maybe (String, String) -> String)
-> (Q -> Maybe (String, String)) -> Q -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q -> Maybe (String, String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"ext" (Q -> HM (Map String a) Response)
-> StateT (Q, Map String a) (ExceptT Response IO) Q
-> HM (Map String a) Response
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (Q, Map String a) (ExceptT Response IO) Q
forall s. HM s Q
get_qs
           String
"rm" -> String -> HM (Map String a) Response
forall s. String -> StateT (Q, s) (ExceptT Response IO) Response
rm (String -> HM (Map String a) Response)
-> StateT (Q, Map String a) (ExceptT Response IO) String
-> HM (Map String a) Response
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (Q, Map String a) (ExceptT Response IO) String
forall s. StateT (Q, s) (ExceptT Response IO) String
look_file
           String
"download" -> String -> HM (Map String a) Response
forall (f :: * -> *). MonadIO f => String -> f Response
download (String -> HM (Map String a) Response)
-> StateT (Q, Map String a) (ExceptT Response IO) String
-> HM (Map String a) Response
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (Q, Map String a) (ExceptT Response IO) String
forall s. StateT (Q, s) (ExceptT Response IO) String
look_file
           String
"link_directories" ->  String -> String -> HM (Map String a) Response
forall s. String -> String -> HM s Response
link_directories String
dir (String -> HM (Map String a) Response)
-> StateT (Q, Map String a) (ExceptT Response IO) String
-> HM (Map String a) Response
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> StateT (Q, Map String a) (ExceptT Response IO) String
forall s. String -> StateT (Q, s) (ExceptT Response IO) String
look String
"newdir"
           String
_ -> Response -> HM (Map String a) Response
forall s a. Response -> HM s a
err (Response -> HM (Map String a) Response)
-> Response -> HM (Map String a) Response
forall a b. (a -> b) -> a -> b
$ String -> Response
resp400 (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
"cloud command "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cmd

    look_file :: StateT (Q, s) (ExceptT Response IO) String
look_file = String -> StateT (Q, s) (ExceptT Response IO) String
forall s. String -> StateT (Q, s) (ExceptT Response IO) String
check (String -> StateT (Q, s) (ExceptT Response IO) String)
-> StateT (Q, s) (ExceptT Response IO) String
-> StateT (Q, s) (ExceptT Response IO) String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> StateT (Q, s) (ExceptT Response IO) String
forall s. String -> StateT (Q, s) (ExceptT Response IO) String
look String
"file"
      where
        check :: String -> StateT (Q, s) (ExceptT Response IO) String
check String
path =
          if String -> Bool
ok_access String
path
          then String -> StateT (Q, s) (ExceptT Response IO) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
path
          else Response -> StateT (Q, s) (ExceptT Response IO) String
forall s a. Response -> HM s a
err (Response -> StateT (Q, s) (ExceptT Response IO) String)
-> Response -> StateT (Q, s) (ExceptT Response IO) String
forall a b. (a -> b) -> a -> b
$ String -> Response
resp400 (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
"unacceptable path "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
path

    make :: ([(String, String)] -> t (String, String))
-> String
-> [(String, String)]
-> StateT (Q, s) (ExceptT Response IO) Response
make [(String, String)] -> t (String, String)
skip String
dir [(String, String)]
args =
      do let ([(String, String)]
flags,[(String, String)]
files) = ((String, String) -> Bool)
-> [(String, String)] -> ([(String, String)], [(String, String)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
"-")(String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1(String -> String)
-> ((String, String) -> String) -> (String, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
args
         Response
_ <- ([(String, String)] -> t (String, String))
-> [(String, String)]
-> StateT (Q, s) (ExceptT Response IO) Response
forall (t :: * -> *) b s.
Foldable t =>
([(String, b)] -> t (String, String))
-> [(String, b)] -> StateT (Q, s) (ExceptT Response IO) Response
upload [(String, String)] -> t (String, String)
skip [(String, String)]
files
         let args :: [String]
args = String
"-s"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"-make"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
flag [(String, String)]
flags[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> a
fst [(String, String)]
files
             flag :: (String, String) -> String
flag (String
n,String
"") = String
n
             flag (String
n,String
v) = String
nString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
v
             cmd :: String
cmd = [String] -> String
unwords (String
"gf"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args)
         String -> StateT (Q, s) (ExceptT Response IO) a
forall (m :: * -> *). MonadIO m => String -> m a
logPutStrLn String
cmd
         out :: (ExitCode, String, String)
out@(ExitCode
ecode,String
_,String
_) <- IO (ExitCode, String, String)
-> StateT (Q, s) (ExceptT Response IO) (ExitCode, String, String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, String, String)
 -> StateT (Q, s) (ExceptT Response IO) (ExitCode, String, String))
-> IO (ExitCode, String, String)
-> StateT (Q, s) (ExceptT Response IO) (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"gf" [String]
args String
""
         String -> StateT (Q, s) (ExceptT Response IO) a
forall (m :: * -> *). MonadIO m => String -> m a
logPutStrLn (String -> StateT (Q, s) (ExceptT Response IO) a)
-> String -> StateT (Q, s) (ExceptT Response IO) a
forall a b. (a -> b) -> a -> b
$ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
ecode
         String
cwd <- StateT (Q, s) (ExceptT Response IO) String
forall (io :: * -> *). MonadIO io => io String
getCurrentDirectory
         Response -> StateT (Q, s) (ExceptT Response IO) Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> StateT (Q, s) (ExceptT Response IO) Response)
-> Response -> StateT (Q, s) (ExceptT Response IO) Response
forall a b. (a -> b) -> a -> b
$ JSValue -> Response
forall a. JSON a => a -> Response
json200 (String
-> String
-> String
-> (ExitCode, String, String)
-> [(String, String)]
-> JSValue
forall a b.
JSON a =>
String
-> String
-> a
-> (ExitCode, String, String)
-> [(String, b)]
-> JSValue
jsonresult String
cwd (Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
:String
dirString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"/") String
cmd (ExitCode, String, String)
out [(String, String)]
files)

    upload :: ([(String, b)] -> t (String, String))
-> [(String, b)] -> StateT (Q, s) (ExceptT Response IO) Response
upload [(String, b)] -> t (String, String)
skip [(String, b)]
files =
        if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
badpaths
        then do IO () -> StateT (Q, s) (ExceptT Response IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (Q, s) (ExceptT Response IO) ())
-> IO () -> StateT (Q, s) (ExceptT Response IO) ()
forall a b. (a -> b) -> a -> b
$ ((String, String) -> IO ()) -> t (String, String) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((String -> String -> IO ()) -> (String, String) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> IO ()
updateFile) ([(String, b)] -> t (String, String)
skip [(String, b)]
okfiles)
                Response -> StateT (Q, s) (ExceptT Response IO) Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
resp204
        else Response -> StateT (Q, s) (ExceptT Response IO) Response
forall s a. Response -> HM s a
err (Response -> StateT (Q, s) (ExceptT Response IO) Response)
-> Response -> StateT (Q, s) (ExceptT Response IO) Response
forall a b. (a -> b) -> a -> b
$ String -> Response
resp404 (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
"unacceptable path(s) "String -> String -> String
forall a. [a] -> [a] -> [a]
++[String] -> String
unwords [String]
badpaths
      where
        ([(String, b)]
okfiles,[String]
badpaths) = ([(String, b)] -> [String])
-> ([(String, b)], [(String, b)]) -> ([(String, b)], [String])
forall b b' a. (b -> b') -> (a, b) -> (a, b')
apSnd (((String, b) -> String) -> [(String, b)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, b) -> String
forall a b. (a, b) -> a
fst) (([(String, b)], [(String, b)]) -> ([(String, b)], [String]))
-> ([(String, b)], [(String, b)]) -> ([(String, b)], [String])
forall a b. (a -> b) -> a -> b
$ ((String, b) -> Bool)
-> [(String, b)] -> ([(String, b)], [(String, b)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (String -> Bool
ok_access(String -> Bool) -> ((String, b) -> String) -> (String, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(String, b) -> String
forall a b. (a, b) -> a
fst) [(String, b)]
files

    skip_empty :: [(a, [a])] -> [(a, [a])]
skip_empty = ((a, [a]) -> Bool) -> [(a, [a])] -> [(a, [a])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> ((a, [a]) -> Bool) -> (a, [a]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null([a] -> Bool) -> ((a, [a]) -> [a]) -> (a, [a]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a, [a]) -> [a]
forall a b. (a, b) -> b
snd)

    jsonList :: String -> HM (Map String a) Response
jsonList = ([String]
 -> StateT (Q, Map String a) (ExceptT Response IO) [String])
-> String -> HM (Map String a) Response
forall (f :: * -> *) a.
(JSON a, MonadIO f) =>
([String] -> f a) -> String -> f Response
jsonList' [String] -> StateT (Q, Map String a) (ExceptT Response IO) [String]
forall (m :: * -> *) a. Monad m => a -> m a
return
    jsonListLong :: String -> f Response
jsonListLong String
ext = ([String] -> f [JSValue]) -> String -> f Response
forall (f :: * -> *) a.
(JSON a, MonadIO f) =>
([String] -> f a) -> String -> f Response
jsonList' ((String -> f JSValue) -> [String] -> f [JSValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> String -> f JSValue
forall (m :: * -> *). MonadIO m => String -> String -> m JSValue
addTime String
ext)) String
ext
    jsonList' :: ([String] -> f a) -> String -> f Response
jsonList' [String] -> f a
details String
ext = (a -> Response) -> f a -> f Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Response
forall a. JSON a => a -> Response
json200) ([String] -> f a
details ([String] -> f a) -> f [String] -> f a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> f [String]
forall (m :: * -> *). MonadIO m => String -> String -> m [String]
ls_ext String
"." String
ext)

    addTime :: String -> String -> m JSValue
addTime String
ext String
path =
        do UTCTime
t <- String -> m UTCTime
forall (m :: * -> *). MonadIO m => String -> m UTCTime
getModificationTime String
path
           if String
extString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
".json"
             then [(String, JSValue)] -> Either IOError String -> JSValue
forall a b. JSON a => [(String, JSValue)] -> Either b a -> JSValue
addComment (UTCTime -> [(String, JSValue)]
time UTCTime
t) (Either IOError String -> JSValue)
-> m (Either IOError String) -> m JSValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either IOError String) -> m (Either IOError String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> IO (Either IOError String)
forall a. IO a -> IO (Either IOError a)
try (IO String -> IO (Either IOError String))
-> IO String -> IO (Either IOError String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
getComment String
path)
             else JSValue -> m JSValue
forall (m :: * -> *) a. Monad m => a -> m a
return (JSValue -> m JSValue)
-> ([(String, JSValue)] -> JSValue)
-> [(String, JSValue)]
-> m JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, JSValue)] -> JSValue
makeObj ([(String, JSValue)] -> m JSValue)
-> [(String, JSValue)] -> m JSValue
forall a b. (a -> b) -> a -> b
$ UTCTime -> [(String, JSValue)]
time UTCTime
t
      where
        addComment :: [(String, JSValue)] -> Either b a -> JSValue
addComment [(String, JSValue)]
t = [(String, JSValue)] -> JSValue
makeObj ([(String, JSValue)] -> JSValue)
-> (Either b a -> [(String, JSValue)]) -> Either b a -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> [(String, JSValue)])
-> (a -> [(String, JSValue)]) -> Either b a -> [(String, JSValue)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([(String, JSValue)] -> b -> [(String, JSValue)]
forall a b. a -> b -> a
const [(String, JSValue)]
t) (\a
c->[(String, JSValue)]
t[(String, JSValue)] -> [(String, JSValue)] -> [(String, JSValue)]
forall a. [a] -> [a] -> [a]
++[String
"comment"String -> a -> (String, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=a
c])
        time :: UTCTime -> [(String, JSValue)]
time UTCTime
t = [String
"path"String -> String -> (String, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=String
path,String
"time"String -> String -> (String, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=UTCTime -> String
format UTCTime
t]
        format :: UTCTime -> String
format = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
rfc822DateFormat

    rm :: String -> StateT (Q, s) (ExceptT Response IO) Response
rm String
path | String -> String
takeExtension String
path String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
ok_to_delete =
      do Bool
b <- String -> StateT (Q, s) (ExceptT Response IO) Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
path
         if Bool
b
           then do String -> StateT (Q, s) (ExceptT Response IO) ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeFile String
path
                   Response -> StateT (Q, s) (ExceptT Response IO) Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> StateT (Q, s) (ExceptT Response IO) Response)
-> Response -> StateT (Q, s) (ExceptT Response IO) Response
forall a b. (a -> b) -> a -> b
$ String -> Response
ok200 String
""
           else Response -> StateT (Q, s) (ExceptT Response IO) Response
forall s a. Response -> HM s a
err (Response -> StateT (Q, s) (ExceptT Response IO) Response)
-> Response -> StateT (Q, s) (ExceptT Response IO) Response
forall a b. (a -> b) -> a -> b
$ String -> Response
resp404 String
path
    rm String
path = Response -> StateT (Q, s) (ExceptT Response IO) Response
forall s a. Response -> HM s a
err (Response -> StateT (Q, s) (ExceptT Response IO) Response)
-> Response -> StateT (Q, s) (ExceptT Response IO) Response
forall a b. (a -> b) -> a -> b
$ String -> Response
resp400 (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
"unacceptable extension "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
path

    download :: String -> m Response
download String
path = IO Response -> m Response
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Response -> m Response) -> IO Response -> m Response
forall a b. (a -> b) -> a -> b
$ String -> IO Response
serveStaticFile' String
path

    link_directories :: String -> String -> HM s Response
link_directories String
olddir newdir :: String
newdir@(Char
'/':Char
't':Char
'm':Char
'p':Char
'/':String
_) | String
oldString -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
new =
        String -> HM s Response -> HM s Response
forall s a. String -> HM s a -> HM s a
hmInDir String
".." (HM s Response -> HM s Response) -> HM s Response -> HM s Response
forall a b. (a -> b) -> a -> b
$ IO Response -> HM s Response
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Response -> HM s Response) -> IO Response -> HM s Response
forall a b. (a -> b) -> a -> b
$
        do String -> IO a
forall (m :: * -> *). MonadIO m => String -> m a
logPutStrLn (String -> IO a) -> IO String -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
forall (io :: * -> *). MonadIO io => io String
getCurrentDirectory
           String -> IO a
forall (m :: * -> *). MonadIO m => String -> m a
logPutStrLn (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"link_dirs new="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
newString -> String -> String
forall a. [a] -> [a] -> [a]
++String
", old="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
old
#ifdef mingw32_HOST_OS
           isDir <- doesDirectoryExist old
           if isDir then removeDir old else removeFile old
           writeFile old new -- poor man's symbolic links
#else
           Bool
isLink <- FileStatus -> Bool
isSymbolicLink (FileStatus -> Bool) -> IO FileStatus -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO FileStatus
getSymbolicLinkStatus String
old
           String -> IO a
forall (m :: * -> *). MonadIO m => String -> m a
logPutStrLn (String -> IO a) -> String -> IO a
forall a b. (a -> b) -> a -> b
$ String
"old is link: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Bool -> String
forall a. Show a => a -> String
show Bool
isLink
           if Bool
isLink then String -> IO ()
removeLink String
old else String -> IO ()
removeDir String
old
           String -> String -> IO ()
createSymbolicLink String
new String
old
#endif
           Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ String -> Response
ok200 String
""
      where
        old :: String
old = String -> String
takeFileName String
olddir
        new :: String
new = String -> String
takeFileName String
newdir
    link_directories String
olddir String
newdir =
      Response -> HM s Response
forall s a. Response -> HM s a
err (Response -> HM s Response) -> Response -> HM s Response
forall a b. (a -> b) -> a -> b
$ String -> Response
resp400 (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
"unacceptable directories "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
olddirString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
newdir

    grammarList :: String -> [(String, String)] -> m Response
grammarList String
dir [(String, String)]
qs =
        do [String]
pgfs <- String -> String -> m [String]
forall (m :: * -> *). MonadIO m => String -> String -> m [String]
ls_ext String
dir String
".pgf"
           Response -> m Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> m Response) -> Response -> m Response
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> [String] -> Response
forall a. JSON a => [(String, String)] -> a -> Response
jsonp [(String, String)]
qs [String]
pgfs

    ls_ext :: String -> String -> m [String]
ls_ext String
dir String
ext =
        do [String]
paths <- String -> m [String]
forall (m :: * -> *). MonadIO m => String -> m [String]
getDirectoryContents String
dir
           [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
path | String
path<-[String]
paths, String -> String
takeExtension String
pathString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
ext]

    getComment :: String -> IO String
getComment String
path =
       do Ok (JSObject JSObject JSValue
obj) <- String -> Result JSValue
forall a. JSON a => String -> Result a
decode (String -> Result JSValue) -> IO String -> IO (Result JSValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
path
          Ok String
cmnt <- Result String -> IO (Result String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> JSObject JSValue -> Result String
forall a. JSON a => String -> JSObject JSValue -> Result a
valFromObj String
"comment" JSObject JSValue
obj)
          String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
cmnt::String)

-- * Dynamic content

jsonresult :: String
-> String
-> a
-> (ExitCode, String, String)
-> [(String, b)]
-> JSValue
jsonresult String
cwd String
dir a
cmd (ExitCode
ecode,String
stdout,String
stderr) [(String, b)]
files =
  [(String, JSValue)] -> JSValue
makeObj [
    String
"errorcode" String -> String -> (String, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.= if ExitCode
ecodeExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
==ExitCode
ExitSuccess then String
"OK" else String
"Error",
    String
"command" String -> a -> (String, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.= a
cmd,
    String
"output" String -> String -> (String, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.= [String] -> String
unlines [String -> String
rel String
stderr,String -> String
rel String
stdout],
    String
"minibar_url" String -> String -> (String, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.= String
"/minibar/minibar.html?"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
dirString -> String -> String
forall a. [a] -> [a] -> [a]
++String
pgf]
  where
    pgf :: String
pgf = case [(String, b)]
files of
            (abstract,_):_ -> String
"%20"String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
dropExtension String
abstractString -> String -> String
forall a. [a] -> [a] -> [a]
++String
".pgf"
            [(String, b)]
_ -> String
""

    rel :: String -> String
rel = [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
relative ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

    -- remove absolute file paths from error messages:
    relative :: String -> String
relative String
s = case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
cwd String
s of
                   Just (Char
'/':String
rest) -> String
rest
                   Maybe String
_ -> String
s

-- * Static content

serveStaticFile :: String -> String -> IO Response
serveStaticFile String
rpath String
path =
  do --logPutStrLn $ "Serving static file "++path
     Bool
b <- String -> IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesDirectoryExist String
path
     if Bool
b
       then if String
rpath String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"",String
"."] Bool -> Bool -> Bool
|| String -> Char
forall a. [a] -> a
last String
pathChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/'
            then String -> IO Response
serveStaticFile' (String
path String -> String -> String
</> String
"index.html")
            else Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Response
resp301 (Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
:String
rpathString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"/"))
       else String -> IO Response
serveStaticFile' String
path

serveStaticFile' :: String -> IO Response
serveStaticFile' String
path =
  do let ext :: String
ext = String -> String
takeExtension String
path
         (String
t,String -> IO String
rdFile) = String -> (String, String -> IO String)
contentTypeFromExt String
ext
     if String
ext String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".cgi",String
".fcgi",String
".sh",String
".php"]
       then Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ String -> Response
resp400 (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
"Unsupported file type: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
ext
       else do Bool
b <- String -> IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
path
               if Bool
b then (String -> Response) -> IO String -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String, String) -> String -> Response
ok200' (String -> String -> (String, String)
forall a. [a] -> [a] -> (String, [a])
ct String
t String
"")) (IO String -> IO Response) -> IO String -> IO Response
forall a b. (a -> b) -> a -> b
$ String -> IO String
rdFile String
path
                    else do String
cwd <- IO String
forall (io :: * -> *). MonadIO io => io String
getCurrentDirectory
                            String -> IO ()
forall (m :: * -> *). Output m => String -> m ()
logPutStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Not found: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
pathString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" cwd="String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cwd
                            Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Response
resp404 String
path)

-- * Logging
logPutStrLn :: String -> m ()
logPutStrLn String
s = String -> m ()
forall (m :: * -> *). Output m => String -> m ()
ePutStrLn String
s

-- * JSONP output

jsonp :: [(String, String)] -> a -> Response
jsonp [(String, String)]
qs =  (a -> Response)
-> (String -> a -> Response) -> Maybe String -> a -> Response
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a -> Response
forall a. JSON a => a -> Response
json200 String -> a -> Response
forall a. JSON a => String -> a -> Response
apply (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"jsonp" [(String, String)]
qs)
  where
    apply :: String -> a -> Response
apply String
f = (String -> String) -> a -> Response
forall a. JSON a => (String -> String) -> a -> Response
jsonp200' ((String -> String) -> a -> Response)
-> (String -> String) -> a -> Response
forall a b. (a -> b) -> a -> b
$ \ String
json -> String
fString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"("String -> String -> String
forall a. [a] -> [a] -> [a]
++String
jsonString -> String -> String
forall a. [a] -> [a] -> [a]
++String
")"

-- * Standard HTTP responses
ok200 :: String -> Response
ok200        = Int -> [(String, String)] -> String -> Response
Response Int
200 [(String, String)
plainUTF8,(String, String)
noCache,(String, String)
xo] (String -> Response) -> (String -> String) -> String -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
encodeString
ok200' :: (String, String) -> String -> Response
ok200' (String, String)
t     = Int -> [(String, String)] -> String -> Response
Response Int
200 [(String, String)
t,(String, String)
xo]
json200 :: a -> Response
json200 a
x    = (String -> String) -> a -> Response
forall a. JSON a => (String -> String) -> a -> Response
json200' String -> String
forall a. a -> a
id a
x
json200' :: (String -> String) -> a -> Response
json200' String -> String
f   = (String, String) -> String -> Response
ok200' (String, String)
jsonUTF8 (String -> Response) -> (a -> String) -> a -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
encodeString (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. JSON a => a -> String
encode
jsonp200' :: (String -> String) -> a -> Response
jsonp200' String -> String
f  = (String, String) -> String -> Response
ok200' (String, String)
jsonpUTF8 (String -> Response) -> (a -> String) -> a -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
encodeString (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. JSON a => a -> String
encode
html200 :: String -> Response
html200    = (String, String) -> String -> Response
ok200' (String, String)
htmlUTF8 (String -> Response) -> (String -> String) -> String -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
encodeString
resp204 :: Response
resp204      = Int -> [(String, String)] -> String -> Response
Response Int
204 [(String, String)
xo] String
"" -- no content
resp301 :: String -> Response
resp301 String
url  = Int -> [(String, String)] -> String -> Response
Response Int
301 [(String, String)
plain,(String, String)
xo,String -> (String, String)
forall b. b -> (String, b)
location String
url] (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$
               String
"Moved permanently to "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
url
resp400 :: String -> Response
resp400 String
msg  = Int -> [(String, String)] -> String -> Response
Response Int
400 [(String, String)
plain,(String, String)
xo] (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
"Bad request: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
msgString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"
resp404 :: String -> Response
resp404 String
path = Int -> [(String, String)] -> String -> Response
Response Int
404 [(String, String)
plain,(String, String)
xo] (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
"Not found: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
pathString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"
resp500 :: String -> Response
resp500 String
msg  = Int -> [(String, String)] -> String -> Response
Response Int
500 [(String, String)
plain,(String, String)
xo] (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
"Internal error: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
msgString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"
resp501 :: String -> Response
resp501 String
msg  = Int -> [(String, String)] -> String -> Response
Response Int
501 [(String, String)
plain,(String, String)
xo] (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
"Not implemented: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
msgString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n"


-- * Content types
plain :: (String, String)
plain = String -> String -> (String, String)
forall a. [a] -> [a] -> (String, [a])
ct String
"text/plain" String
""
plainUTF8 :: (String, String)
plainUTF8 = String -> String -> (String, String)
forall a. [a] -> [a] -> (String, [a])
ct String
"text/plain" String
csutf8
jsonUTF8 :: (String, String)
jsonUTF8 = String -> String -> (String, String)
forall a. [a] -> [a] -> (String, [a])
ct String
"application/json" String
csutf8 -- http://www.ietf.org/rfc/rfc4627.txt
jsonpUTF8 :: (String, String)
jsonpUTF8 = String -> String -> (String, String)
forall a. [a] -> [a] -> (String, [a])
ct String
"application/javascript" String
csutf8
htmlUTF8 :: (String, String)
htmlUTF8 = String -> String -> (String, String)
forall a. [a] -> [a] -> (String, [a])
ct String
"text/html" String
csutf8

ct :: [a] -> [a] -> (String, [a])
ct [a]
t [a]
cs = (String
"Content-Type",[a]
t[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
cs)
csutf8 :: String
csutf8 = String
"; charset=UTF-8"
xo :: (String, String)
xo = (String
"Access-Control-Allow-Origin",String
"*") -- Allow cross origin requests
     -- https://developer.mozilla.org/en-US/docs/HTTP/Access_control_CORS
location :: b -> (String, b)
location b
url = (String
"Location",b
url)

contentTypeFromExt :: String -> (String, String -> IO String)
contentTypeFromExt String
ext =
  case String
ext of
    String
".html" -> String -> (String, String -> IO String)
text String
"html"
    String
".htm" -> String -> (String, String -> IO String)
text String
"html"
    String
".xml" -> String -> (String, String -> IO String)
text String
"xml"
    String
".txt" -> String -> (String, String -> IO String)
text String
"plain"
    String
".css" -> String -> (String, String -> IO String)
text String
"css"
    String
".js" -> String -> (String, String -> IO String)
text String
"javascript"
    String
".png" -> String -> (String, String -> IO String)
forall a. a -> (a, String -> IO String)
bin String
"image/png"
    String
".jpg" -> String -> (String, String -> IO String)
forall a. a -> (a, String -> IO String)
bin String
"image/jpg"
    String
_ -> String -> (String, String -> IO String)
forall a. a -> (a, String -> IO String)
bin String
"application/octet-stream"
  where
     text :: String -> (String, String -> IO String)
text String
subtype = (String
"text/"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
subtypeString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"; charset=UTF-8",
                     (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
encodeString (IO String -> IO String)
-> (String -> IO String) -> String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
readFile)
     bin :: a -> (a, String -> IO String)
bin a
t = (a
t,String -> IO String
readBinaryFile)

-- * IO utilities
updateFile :: String -> String -> IO ()
updateFile String
path String
new =
  do Either IOError String
old <- IO String -> IO (Either IOError String)
forall a. IO a -> IO (Either IOError a)
try (IO String -> IO (Either IOError String))
-> IO String -> IO (Either IOError String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
readBinaryFile String
path
--   let new = encodeString new0
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Either IOError String
forall a b. b -> Either a b
Right String
newEither IOError String -> Either IOError String -> Bool
forall a. Eq a => a -> a -> Bool
/=Either IOError String
old) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do String -> IO ()
forall (m :: * -> *). Output m => String -> m ()
logPutStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Updating "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
path
                                Int -> IO () -> IO ()
seq ((IOError -> Int) -> (String -> Int) -> Either IOError String -> Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Int -> IOError -> Int
forall a b. a -> b -> a
const Int
0) String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Either IOError String
old) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                    String -> String -> IO ()
writeBinaryFile String
path String
new

-- | Check that a path is not outside the current directory
ok_access :: String -> Bool
ok_access String
path =
    case String
path of
      Char
'/':String
_ -> Bool
False
      Char
'.':Char
'.':Char
'/':String
_ -> Bool
False
      String
_ -> Bool -> Bool
not (String
"/../" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
path)

-- | Only delete files with these extensions
ok_to_delete :: [String]
ok_to_delete = [String
".json",String
".gfstdoc",String
".gfo",String
".gf",String
".pgf"]

newDirectory :: IO String
newDirectory =
    do String -> IO ()
forall (m :: * -> *). Output m => String -> m ()
debug String
"newDirectory"
       Integer -> IO String
forall t. (Eq t, Num t) => t -> IO String
loop Integer
10
  where
    loop :: t -> IO String
loop t
0 = String -> IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to create a new directory"
    loop t
n = IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (t -> IO String
loop (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1)) String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO String) -> IO (Maybe String) -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe String)
once

    once :: IO (Maybe String)
once =
      do Int
k <- (Int, Int) -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
1,Int
forall a. Bounded a => a
maxBound::Int)
         let path :: String
path = String
"tmp/gfse."String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
k
         Either IOError ()
b <- IO () -> IO (Either IOError ())
forall a. IO a -> IO (Either IOError a)
try (IO () -> IO (Either IOError ()))
-> IO () -> IO (Either IOError ())
forall a b. (a -> b) -> a -> b
$ String -> IO ()
createDirectory String
path
         case Either IOError ()
b of
           Left IOError
err -> do String -> IO ()
forall (m :: * -> *). Output m => String -> m ()
debug (IOError -> String
forall a. Show a => a -> String
show IOError
err) ;
                          if IOError -> Bool
isAlreadyExistsError IOError
err
                             then Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                             else IOError -> IO (Maybe String)
forall a. IOError -> IO a
ioError IOError
err
           Right ()
_ -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just (Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
:String
path))

-- | Remove a directory and the files in it, but not recursively
removeDir :: String -> IO ()
removeDir String
dir =
  do [String]
files <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
".",String
".."]) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO [String]
forall (m :: * -> *). MonadIO m => String -> m [String]
getDirectoryContents String
dir
     (String -> IO ()) -> [String] -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
removeFile (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
dirString -> String -> String
</>)) [String]
files
     String -> IO ()
removeDirectory String
dir

setDir :: String -> IO ()
setDir String
path =
  do --logPutStrLn $ "cd "++show path
     String -> IO ()
setCurrentDirectory String
path

{-
-- * direct-fastcgi deficiency workaround

--toHeader = FCGI.toHeader -- not exported, unfortuntately

toHeader "Content-Type" = FCGI.HttpContentType -- to avoid duplicate headers
toHeader s = FCGI.HttpExtensionHeader s -- cheating a bit
-}

-- * misc utils

--utf8inputs = mapBoth decodeString . inputs
type Q = [(String,(String,String))]
utf8inputs :: String -> Q
utf8inputs :: String -> Q
utf8inputs String
q = [(String -> String
decodeString String
k,(String -> String
decodeString String
v,String
v))|(String
k,String
v)<-String -> [(String, String)]
inputs String
q]
decoded :: [(a, (b', b))] -> [(a, b')]
decoded = ((b', b) -> b') -> [(a, (b', b))] -> [(a, b')]
forall b b' a. (b -> b') -> [(a, b)] -> [(a, b')]
mapSnd (b', b) -> b'
forall a b. (a, b) -> a
fst
raw :: [(a, (a, b'))] -> [(a, b')]
raw = ((a, b') -> b') -> [(a, (a, b'))] -> [(a, b')]
forall b b' a. (b -> b') -> [(a, b)] -> [(a, b')]
mapSnd (a, b') -> b'
forall a b. (a, b) -> b
snd

inputs :: String -> [(String, String)]
inputs (Char
'?':String
q) = String -> [(String, String)]
decodeQuery String
q
inputs String
q = String -> [(String, String)]
decodeQuery String
q

{-
-- Stay clear of queryToArgument, which uses unEscapeString, which had
-- backward incompatible changes in network-2.4.1.1, see
-- https://github.com/haskell/network/commit/f2168b1f8978b4ad9c504e545755f0795ac869ce
inputs = queryToArguments . fixplus
  where
    fixplus = concatMap decode
    decode '+' = "%20" -- httpd-shed bug workaround
    decode c   = [c]
-}

infix 1 .=
a
n .= :: a -> a -> (a, JSValue)
.= a
v = (a
n,a -> JSValue
forall a. JSON a => a -> JSValue
showJSON a
v)