{-# OPTIONS_GHC -fglasgow-exts #-}
module Main 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 Fenfire.RDF
import Fenfire.Utils
import qualified Fenfire.Raptor as Raptor

import HAppS

import Control.Monad (liftM)
import Control.Monad.State (State, get, gets, put, modify, execState)

import qualified Data.ByteString as ByteString
import Data.ByteString (ByteString)
import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Maybe (fromMaybe, fromJust)
import Data.Typeable

import Network.URI (uriToString)

import System.IO.Unsafe (unsafePerformIO)

fs                 =     "http://fenfire.org/2007/fenserve#"
fs_Directory       = IRI "http://fenfire.org/2007/fenserve#Directory"
fs_DirEntry        = IRI "http://fenfire.org/2007/fenserve#DirEntry"
fs_FileEntry       = IRI "http://fenfire.org/2007/fenserve#FileEntry"
fs_FirstVersion    = IRI "http://fenfire.org/2007/fenserve#FirstVersion"
fs_previousVersion = IRI "http://fenfire.org/2007/fenserve#previousVersion"
fs_entries         = IRI "http://fenfire.org/2007/fenserve#entries"
fs_filename        = IRI "http://fenfire.org/2007/fenserve#filename"
fs_subdir          = IRI "http://fenfire.org/2007/fenserve#"
fs_representation  = IRI "http://fenfire.org/2007/fenserve#representation"
fs_mimeType        = IRI "http://fenfire.org/2007/fenserve#mimeType"
fs_language        = IRI "http://fenfire.org/2007/fenserve#language"

rget :: Node -> Node -> Graph -> Node
rget p s g = fromJust $ getOne g s p Pos

data Entry = DirEntry { entryName :: String, entrySubdir :: Node }
           | FileEntry { entryName :: String, entryRepr :: Node } deriving (Show, Read)
           
data Directory = Dir { dirNode :: Node, dirEntries :: [Entry] } deriving (Show, Read)

emptyState :: Ptr
emptyState = runStormIO (writeBlock (Dir (IRI "#dir") [])) Map.empty

type Ptr = (BlockId, Pool)

instance ToRDF Directory where
    toRDF (Dir node entries) = do
        l <- toRDF entries
        tellTs [ (node, rdf_type, fs_Directory), (node, fs_entries, l) ]
        return node
        
instance FromRDF Directory where
    readRDF g node = do
        let l = rget fs_entries node g
        tellTs [ (node, rdf_type, fs_Directory), (node, fs_entries, l) ]
        entries <- readRDF g l
        return $ Dir node entries
        
instance ToRDF Entry where
    toRDF (FileEntry name repr) = do
        e <- newBNode; nameR <- toRDF name
        tellTs [ (e, fs_filename, nameR), (e, rdf_type, fs_FileEntry),
                 (e, fs_representation, repr) ]
        return e
    toRDF (DirEntry name subdir) = do
        e <- newBNode; nameR <- toRDF name
        tellTs [ (e, fs_filename, nameR), (e, rdf_type, fs_DirEntry),
                 (e, fs_subdir, subdir) ]
        return e
        
instance FromRDF Entry where
    readRDF g node = case rget rdf_type node g of
        x | x == fs_FileEntry -> do
            let nameR = rget fs_filename node g
            name <- readRDF g nameR
            let repr = rget fs_representation node g
            tellTs [ (node, fs_filename, nameR), 
                     (node, fs_representation, repr) ]
            return $ FileEntry name repr
        x | x == fs_DirEntry -> do
            let nameR = rget fs_filename node g
            name <- readRDF g nameR
            let subdir = rget fs_representation node g
            tellTs [ (node, fs_filename, nameR), 
                     (node, fs_subdir, subdir) ]
            return $ DirEntry name subdir

instance StartState Ptr where startStateM = return emptyState

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

instance ToMessage ByteString where
    toMessageBodyM = return

asPath :: SURI -> Maybe [String]
asPath = Just . splitPath . path

main :: IO ()
main = stdHTTP
  [ debugFilter
  , h asPath GET $ ok $ \uri () -> get >>= return . Right . getURI uri
  , h asPath PUT $ ok $ \uri () -> do 
      Request { rqBody=Body body } <- getEvent
      modify (\(b,p) -> runStormIO (putURI uri body b) p); return $ Right "Ok."
  ]
  
bURI :: BlockId -> String
bURI (BlockId bid) = "blk:" ++ bid
  
bIRI :: BlockId -> Node
bIRI bid = IRI $ bURI bid

bID :: Node -> BlockId
bID (IRI ('b':'l':'k':':':s)) = BlockId $ takeWhile (/= '#') s
  
readGraph :: BlockId -> StormIO Graph
readGraph bid = liftM (setGraphURI $ bURI bid) $ readBlock bid

getURI :: [String] -> (BlockId, Pool) -> ByteString
getURI [x] (bid,pool) = f entries where
    Dir _ entries = fst $ runStormIO (readBlock bid) pool
    f (FileEntry n r : _ ) | n == x = fst $ runStormIO (getBlock (bID r)) pool
    f (_             : es) = f es
    f []                   = toUTF $ "not found: " ++ x
getURI (x:xs) (bid,pool) = f entries where
    Dir _ entries = fst $ runStormIO (readBlock bid) pool
    f (DirEntry n sub : _ ) | n == x = getURI xs (bID sub, pool)
    f (_              : es) = f es
    f []                    = toUTF $ "dir not found: " ++ x

{-
updateData :: (FromRDF a, ToRDF a) => (a -> a) -> Node -> Endo (BlockId,Pool)
updateData f node (bid,pool) = let graph = readGraph (bid, pool)
                                   graph' = updateRDF f node graph
                                in writeGraph graph' pool
-}

updateData :: (Read a, Show a) => EndoM StormIO a -> EndoM StormIO BlockId
updateData f bid = writeBlock =<< f =<< readBlock bid

putURI :: [String] -> ByteString -> BlockId -> StormIO BlockId
putURI path s bid = do rid <- addBlock s; putURI' path (bIRI rid) bid where
    upd :: String -> (EndoM StormIO Entry) -> Entry -> EndoM StormIO Directory
    upd fn f dflt (Dir n es) = do es' <- upd' fn f dflt es; return (Dir n es')
    upd' fn f dflt (e:es) | entryName e == fn = do e' <- f e; return (e':es)
    upd' fn f dflt (e:es) = do es' <- upd' fn f dflt es; return (e:es')
    upd' _  f dflt []     = do e <- f dflt; return [e]
    
    putURI' [x] r = updateData (upd x (const $ return e) e) where e = FileEntry x r
    putURI' (x:xs) r = updateData (upd x f (DirEntry x (bIRI $ fst emptyState))) where
        f (DirEntry n sub) = do sub' <- putURI' xs r (bID sub)
                                return $ DirEntry x (bIRI sub')

--------------------------------------------------------------------------
-- 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"

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