msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

GFServer.hs: binary files can now be uploaded to the cloud

Browse Source 
Karel wants to upload PGF files.
This commit is contained in:
hallgren
2012-08-01 18:10:00 +00:00
parent dca98c3533
commit 860a014f2e
1 changed files with 14 additions and 10 deletions
Download Patch File Download Diff File Expand all files Collapse all files

24
src/compiler/GFServer.hs
View File

@@ -99,18 +99,18 @@ handle state0 cache execute1
_ -> return (state,resp501 $ "method "++method) _ -> return (state,resp501 $ "method "++method)
where where
normal_request qs = normal_request qs =
do logPutStrLn $ method++" "++upath++" "++show qs do logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs)
case upath of case upath of
"/new" -> new "/new" -> new
-- "/stop" -> -- "/stop" ->
-- "/start" -> -- "/start" ->
"/gfshell" -> inDir qs $ look "command" . command "/gfshell" -> inDir qs $ look "command" . command
"/parse" -> parse qs "/parse" -> parse (decoded qs)
"/cloud" -> inDir qs $ look "command" . cloud "/cloud" -> inDir qs $ look "command" . cloud
'/':rpath -> '/':rpath ->
case (takeDirectory path,takeFileName path,takeExtension path) of case (takeDirectory path,takeFileName path,takeExtension path) of
(_ ,_ ,".pgf") -> wrapCGI $ PS.cgiMain' cache path (_ ,_ ,".pgf") -> wrapCGI $ PS.cgiMain' cache path
(dir,"grammars.cgi",_ ) -> grammarList dir qs (dir,"grammars.cgi",_ ) -> grammarList dir (decoded qs)
(dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir cache (dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir cache
_ -> do resp <- serveStaticFile path _ -> do resp <- serveStaticFile path
return (state,resp) return (state,resp)
@@ -127,7 +127,7 @@ handle state0 cache execute1
look field ok qs = look field ok qs =
case partition ((==field).fst) qs of case partition ((==field).fst) qs of
((_,value):qs1,qs2) -> ok value (qs1++qs2) ((_,(value,_)):qs1,qs2) -> ok value (qs1++qs2)
_ -> bad _ -> bad
where where
bad = return (state,resp400 $ "no "++field++" in request") bad = return (state,resp400 $ "no "++field++" in request")
@@ -163,9 +163,9 @@ handle state0 cache execute1
cloud dir cmd qs = cloud dir cmd qs =
case cmd of case cmd of
"make" -> make dir qs "make" -> make dir (raw qs)
"upload" -> upload qs "upload" -> upload (raw qs)
"ls" -> jsonList (maybe ".json" id $ lookup "ext" qs) "ls" -> jsonList (maybe ".json" fst $ lookup "ext" qs)
"rm" -> look "file" rm qs "rm" -> look "file" rm qs
"download" -> look "file" download qs "download" -> look "file" download qs
"link_directories" -> look "newdir" (link_directories dir) qs "link_directories" -> look "newdir" (link_directories dir) qs
@@ -353,9 +353,9 @@ contentTypeFromExt ext =
bin t = (t,readBinaryFile) bin t = (t,readBinaryFile)
-- * IO utilities -- * IO utilities
updateFile path new0 = updateFile path new =
do old <- try $ readBinaryFile path do old <- try $ readBinaryFile path
let new = encodeString new0 -- let new = encodeString new0
when (Right new/=old) $ do logPutStrLn $ "Updating "++path when (Right new/=old) $ do logPutStrLn $ "Updating "++path
seq (either (const 0) length old) $ seq (either (const 0) length old) $
writeBinaryFile path new writeBinaryFile path new
@@ -394,7 +394,10 @@ toHeader s = FCGI.HttpExtensionHeader s -- cheating a bit
-- * misc utils -- * misc utils
utf8inputs = mapBoth decodeString . inputs --utf8inputs = mapBoth decodeString . inputs
utf8inputs q = [(decodeString k,(decodeString v,v))|(k,v)<-inputs q]
decoded = mapSnd fst
raw = mapSnd snd
inputs = queryToArguments . fixplus inputs = queryToArguments . fixplus
where where
@@ -403,6 +406,7 @@ inputs = queryToArguments . fixplus
decode c = [c] decode c = [c]
mapFst f xys = [(f x,y)|(x,y)<-xys] mapFst f xys = [(f x,y)|(x,y)<-xys]
mapSnd f xys = [(x,f y)|(x,y)<-xys]
mapBoth = map . apBoth mapBoth = map . apBoth
apBoth f (x,y) = (f x,f y) apBoth f (x,y) = (f x,f y)