{-# OPTIONS_GHC -fglasgow-exts #-}
module FenServe where

-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup
-- This file is part of Fenfire.
-- 
-- Fenfire is free software; you can redistribute it and/or modify it under
-- the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
-- 
-- Fenfire is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General
-- Public License for more details.
-- 
-- You should have received a copy of the GNU General
-- Public License along with Fenfire; if not, write to the Free
-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
-- MA  02111-1307  USA

import Storm
import StormData
import Fenfire.RDF
import Fenfire.Utils
import qualified Fenfire.Raptor as Raptor

import HAppS hiding (query, Handler, getPath)

import Control.Monad (liftM, when, forM)
import Control.Monad.Error (ErrorT, throwError, runErrorT)
import Control.Monad.State (State, StateT, runStateT,
                            get, gets, put, modify, execState)
import Control.Monad.Trans (lift, liftIO)

import qualified Data.ByteString as ByteString
import Data.ByteString (ByteString)
import Data.Generics
import Data.IORef
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Maybe (fromMaybe, fromJust, isJust)
import Data.Typeable

import Language.Haskell.Hsx as Hsx

import Network.URI (uriToString, parseURIReference)

import System.Directory (doesFileExist, createDirectoryIfMissing)
import System.Environment (getEnv, getProgName)
import System.Eval.Haskell (eval)
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import qualified System.Plugins as Plugins

fs                 =     "http://fenfire.org/2007/fenserve#"
fs_Directory       = IRI "http://fenfire.org/2007/fenserve#Directory"
fs_File            = IRI "http://fenfire.org/2007/fenserve#File"
fs_Executable      = IRI "http://fenfire.org/2007/fenserve#Executable"
fs_FirstVersion    = IRI "http://fenfire.org/2007/fenserve#FirstVersion"
fs_previousVersion = IRI "http://fenfire.org/2007/fenserve#previousVersion"
fs_entry           = IRI "http://fenfire.org/2007/fenserve#entry"
fs_filename        = IRI "http://fenfire.org/2007/fenserve#filename"
fs_spec            = IRI "http://fenfire.org/2007/fenserve#spec"
fs_representation  = IRI "http://fenfire.org/2007/fenserve#representation"
fs_code            = IRI "http://fenfire.org/2007/fenserve#code"
fs_mimeType        = IRI "http://fenfire.org/2007/fenserve#mimeType"
fs_language        = IRI "http://fenfire.org/2007/fenserve#language"

fs_type            = IRI "http://fenfire.org/2007/fenserve#type"

storm              =     "http://fenfire.org/2007/storm"
storm_depends      = IRI "http://fenfire.org/2007/storm#depends"

type FenServe = StateT Node StormIO

runFenServe :: FenServe a -> Node -> Maybe FilePath -> IO (a, Node, Pool)
runFenServe m node dir = do ((r,n),p) <- runStormIO (runStateT m node) dir
                            return (r,n,p)
    
instance StormMonad FenServe where
    getBlock = lift . getBlock
    addBlock = lift . addBlock

mkResult :: Int -> String -> ByteString -> Result
mkResult code mimeType body = Result {
    rsCode=code, rsFlags=nullRsFlags, rsBody=[body], rsHeaders = Headers $
        Map.singleton (toUTF "Content-type") (toUTF mimeType) }

unBody NoBody = ByteString.empty
unBody (Body b) = b
unBody (LargeBody _ _) = error "FenServe.unBody: large body not handled"

type Handler = Request -> FenServe Result

data Resource = Resource {
    getResource :: FromRDF a => FenServe a,
    putResource :: ToRDF a => a -> FenServe (),
    handleResource :: Handler }
    
type Resolvers = Map Node Resolver
data Resolver = Resolver (Resolvers -> Node -> (Node -> FenServe ()) 
                       -> [String] -> FenServe Resource)

writeEmptyState :: FenServe Node
writeEmptyState = addData $ Dir (Map.empty)

instance StartState Node where 
    startStateM =
        runFenServe writeEmptyState e Nothing >>= \(r,_,_) -> return r  where
            e = error "FenServe.(StartState Node): this shouldn't be evaluated"

instance Serialize Node where
    typeString _  = "FenServe.State"
    decodeStringM = defaultDecodeStringM
    encodeStringM = defaultEncodeStringM

instance ToMessage ByteString where
    toMessageBodyM = return
    
resolve :: Resolvers -> [String] -> FenServe Resource
resolve rs p = do root <- get; resolve' rs root put p

resolve' :: Resolvers -> Node -> (Node -> FenServe ()) -> [String] -> FenServe Resource
resolve' rs n put' p = do g <- getGraph n; ty <- mquery (n, fs_type, X) g
                          Resolver r <- Map.lookup ty rs
                          let Right spec = fromRDF g n
                          r rs spec (\x -> addData x >>= put') p

defaultResolvers = Map.fromList [(fs_Directory, Resolver resolveDir),
                                 (fs_File, Resolver resolveFile)]

handleRequest :: Request -> FenServe Result
handleRequest req = do let p = splitPath $ path $ rqURI req
                       r <- resolve defaultResolvers p
                       handleResource r req
                       
toResourceRDF :: Node -> [Node -> ToRdfM ()] -> ToRdfM Node
toResourceRDF ty fs = do n <- newFrag; tellTs [(n, fs_type, ty)]
                         mapM ($ n) fs; return n
                       
data File = File Node

instance FromRDF File where 
  fromRDF g n = fmap File $ fromRDFConn fs_representation fromRDF g n
instance ToRDF File where
  toRDF (File n) = toResourceRDF fs_File [addRDFConn fs_representation toRDF n]

resolveFile rs node put' [] = do File n <- getData node; return $ Resource {
    getResource = getData node,
    putResource = \x -> addData x >>= put',
    handleResource = \req -> case rqMethod req of
        GET -> do bytes <- getBlock (bID n)
                  return $ mkResult 200 "text/html" bytes
        PUT -> do bid <- addBlock (unBody $ rqBody req)
                  addData (File $ bIRI bid) >>= put'
                  return $ mkResult 200 "text/html" (toUTF "Ok.\n")
    }
                       
data Directory = Dir (Map String Node)

instance FromRDF Directory where 
    fromRDF g n = fmap (Dir . Map.fromList) $ fromRDFConns fs_entry
        (fromRDFPair fs_filename fromRDF fs_spec fromRDF) g n
instance ToRDF Directory where 
    toRDF (Dir m) = toResourceRDF fs_Directory
        [ addRDFConns fs_entry
             (toRDFPair fs_filename toRDF fs_spec toRDF) (Map.toList m)
        ]

resolveDir rs node put' (p:ps) = do 
    Dir m <- getData node; case Map.lookup p m of
        Just n -> resolve' rs n (\n' -> put' =<< (addData $ Dir $ Map.insert p n' m)) ps
        Nothing -> do emptyBlock <- liftM bIRI $ addBlock ByteString.empty
                      emptyFile <- addData (File emptyBlock)
                      resolveFile rs emptyFile
                        (\n' -> put' =<< addData (Dir $ Map.insert p n' m)) ps
resolveDir rs node put' [] = resolveDir rs node put' [""]


--------------------------------------------------------------------------
-- Running executable resources
--------------------------------------------------------------------------

imports = ["Fenfire.RDF",
           "Fenfire.Utils ((!?), Endo, maybeDo, BreadthT, scheduleBreadthT, execBreadthT)",
           "HAppS hiding (Handler, query)",
           "PagePrelude", "Storm", "FenServe",
           "Control.Monad", "Control.Monad.State", 
           "Control.Monad.Writer hiding (Endo,Any)",
           "Control.Monad.Reader", "Data.Maybe",
           "qualified Data.ByteString as ByteString",
           "qualified Data.List as List",
           "qualified Data.Map as Map",
           "qualified Data.Set as Set"]
           
codeCache :: IORef (Map BlockId Handler)
codeCache = unsafePerformIO $ newIORef Map.empty

getCodeDir :: IO FilePath
getCodeDir = fmap (++"_code/") getProgName

{-
realize :: Node -> FilePath -> ErrorT String FenServe FilePath
realize code codeDir = do
    let err stage msg = throwError (stage ++ " failed:\n" ++ msg)
        mname = "Block_"++(blockId $ bID code); fp = codeDir++mname++".hs"
        
    liftIO $ createDirectoryIfMissing True codeDir
    dfe <- liftIO $ doesFileExist fp
    when (not dfe) $ do
        code2 <- lift $ getBlock (bID code)
        
        let (imps, body) = span (List.isPrefixOf "import ") $ lines $fromUTF code2
        
        imps' <- forM imps $ \uri -> do
            icode <- lift $ wget (drop (length "import ") uri)
            bid <- lift $ addBlock icode
            realize (bIRI bid) codeDir
            return ("Block_" ++ blockId bid)
        
        let code3 = "module " ++ mname ++ " where\n" ++
                    concatMap (\i -> "import "++i++"\n") (imps'++imports) ++
                    "dummyAssignment = 0\n" ++ unlines body
                    -- the 'dummyAssignment' is to make sure that
                    -- pages can't import anything -- imports are
                    -- syntactically disallowed except at the beginning
                    
        parsed <- case Hsx.parseModuleWithMode (Hsx.ParseMode fp) $ code3 of
                ParseFailed (SrcLoc file line col) e -> 
                    err "HSP preprocessing" $ 
                        "At "++show line++":"++show col++" in "++file++": "++e
                ParseOk parsed -> return parsed

        let code4 = Hsx.prettyPrintWithMode 
                        (Hsx.defaultMode {Hsx.linePragmas=True}) $
                        Hsx.transform parsed

        hdl <- liftIO $ openFile fp WriteMode
        liftIO $ hPutStr hdl code4
        liftIO $ hClose hdl
                    
    return fp

execute :: Node -> Request -> FenServe Result
execute code req = let f (Left msg) = return $ mkResult 500 "text/plain" $ toUTF $ msg
                       f (Right h) = h req
                       f' m = m >>= f
                    in f' $ runErrorT $ do

    let err stage msg = throwError (stage ++ " failed:\n" ++ msg)

    cached <- liftM (Map.lookup $ bID code) $ liftIO $ readIORef codeCache
    if isJust cached then return (fromJust cached) else do
    
    codeDir <- liftIO getCodeDir
    fp <- realize code codeDir

    homedir <- liftIO $ getEnv "HOME"
    makeResult <- liftIO $ Plugins.makeAll fp ["-fglasgow-exts", "-fallow-overlapping-instances","-i","-i"++codeDir]
    o <- case makeResult of
        Plugins.MakeFailure e -> err "Make" $ concat (List.intersperse "\n" e)
        Plugins.MakeSuccess _ o -> return o
    loadStatus <- liftIO $ Plugins.load o [codeDir] [homedir ++ "/.ghc/i386-linux-6.6/package.conf"] "handler"
    h <- case loadStatus of
        Plugins.LoadFailure e -> err "Load" $ concat (List.intersperse "\n" e)
        Plugins.LoadSuccess _ h -> return h
    --liftIO $ Plugins.makeCleaner fp
    liftIO $ modifyIORef codeCache (Map.insert (bID code) h)
    return h
-}


--------------------------------------------------------------------------
-- Copied from HAppS.Protocols.SimpleHTTP2, which is BSD3-licensed
--------------------------------------------------------------------------

splitPath         :: String -> [String]
splitPath ('/':x) = a : splitPath b where (a,b) = break (=='/') x
splitPath []      = []
splitPath _       = error "splitPath: malformed path"

--------------------------------------------------------------------------