module Development.Cake3.Ext.UrWeb where
import Data.Data
import Data.Char
import Data.Typeable
import Data.Generics
import Data.Maybe
import Data.Monoid
import Data.List ()
import qualified Data.List as L
import Data.Set (Set)
import qualified Data.Set as S
import Data.Foldable (Foldable(..), foldl')
import qualified Data.Foldable as F
import Data.ByteString.Char8 (ByteString(..))
import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as T
import Data.String
import Control.Applicative
import Control.Monad.Trans
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Error
import Language.JavaScript.Parser
import Network.Mime (defaultMimeLookup)
import System.Directory
import Text.Printf
import qualified System.FilePath as F
import System.IO as IO
import System.FilePath.Wrapper
import Development.Cake3.Monad
import Development.Cake3
data UrpAllow = UrpMime | UrpUrl
deriving(Show,Data,Typeable)
data UrpRewrite = UrpStyle
deriving(Show,Data,Typeable)
data UrpHdrToken = UrpDatabase String
| UrpSql File
| UrpAllow UrpAllow String
| UrpRewrite UrpRewrite String
| UrpLibrary File
| UrpDebug
| UrpInclude File
| UrpLink File
| UrpFFI File
| UrpJSFunc String String
| UrpSafeGet String
deriving(Show,Data,Typeable)
data UrpModToken
= UrpModule1 File
| UrpModule2 File File
| UrpModuleSys String
deriving(Show,Data,Typeable)
data Urp = Urp {
urp :: File
, uexe :: Maybe File
, uhdr :: [UrpHdrToken]
, umod :: [UrpModToken]
} deriving(Show,Data,Typeable)
newtype UWLib = UWLib Urp
deriving (Show,Data,Typeable)
newtype UWExe = UWExe Urp
deriving (Show,Data,Typeable)
instance (MonadAction a m) => RefInput a m UWLib where
refInput (UWLib u) = refInput (urp u)
instance (MonadAction a m) => RefInput a m UWExe where
refInput (UWExe u) = refInput (urpExe u)
urpDeps :: Urp -> [File]
urpDeps (Urp _ _ hdr mod) = foldl' scan2 (foldl' scan1 mempty hdr) mod where
scan1 a (UrpLink f) = f:a
scan1 a (UrpInclude f) = f:a
scan1 a _ = a
scan2 a (UrpModule1 f) = f:a
scan2 a (UrpModule2 f1 f2) = f1:f2:a
scan2 a _ = a
urpSql' :: Urp -> Maybe File
urpSql' (Urp _ _ hdr _) = find hdr where
find [] = Nothing
find ((UrpSql f):hs) = Just f
find (h:hs) = find hs
urpSql :: Urp -> File
urpSql u = case urpSql' u of
Nothing -> error "ur project defines no SQL file"
Just sql -> sql
urpObjs (Urp _ _ hdr _) = foldl' scan [] hdr where
scan a (UrpLink f) = f:a
scan a _ = a
urpLibs (Urp _ _ hdr _) = foldl' scan [] hdr where
scan a (UrpLibrary f) = f:a
scan a _ = a
urpExe u = case uexe u of
Nothing -> error "ur project defines no EXE file"
Just exe -> exe
data UrpState = UrpState {
urpst :: Urp
} deriving (Show)
defState urp = UrpState (Urp urp Nothing [] [])
class ToUrpWord a where
toUrpWord :: a -> String
instance ToUrpWord UrpAllow where
toUrpWord (UrpMime) = "mime"
toUrpWord (UrpUrl) = "url"
instance ToUrpWord UrpRewrite where
toUrpWord (UrpStyle) = "style"
class ToUrpLine a where
toUrpLine :: FilePath -> a -> String
instance ToUrpLine UrpHdrToken where
toUrpLine up (UrpDatabase dbs) = printf "database %s" dbs
toUrpLine up (UrpSql f) = printf "sql %s" (up </> toFilePath f)
toUrpLine up (UrpAllow a s) = printf "allow %s %s" (toUrpWord a) s
toUrpLine up (UrpRewrite a s) = printf "rewrite %s %s" (toUrpWord a) s
toUrpLine up (UrpLibrary f) = printf "library %s" (up </> toFilePath (dropExtensions f))
toUrpLine up (UrpDebug) = printf "debug"
toUrpLine up (UrpInclude f) = printf "include %s" (up </> toFilePath f)
toUrpLine up (UrpLink f) = printf "link %s" (up </> toFilePath f)
toUrpLine up (UrpFFI s) = printf "ffi %s" (up </> toFilePath (dropExtensions s))
toUrpLine up (UrpSafeGet s) = printf "safeGet %s" (dropExtensions s)
instance ToUrpLine UrpModToken where
toUrpLine up (UrpModule1 f) = up </> toFilePath (dropExtensions f)
toUrpLine up (UrpModule2 f _) = up </> toFilePath (dropExtensions f)
toUrpLine up (UrpModuleSys s) = printf "$/%s" s
newtype UrpGen m a = UrpGen { unUrpGen :: StateT UrpState m a }
deriving(Functor, Applicative, Monad, MonadState UrpState, MonadMake, MonadIO)
instance (Monad m) => MonadAction (UrpGen (A' m)) m where
liftAction a = UrpGen (lift a)
toFile f wr = liftIO $ writeFile (toFilePath f) $ execWriter $ wr
line :: (MonadWriter String m) => String -> m ()
line s = tell (s++"\n")
uwlib :: File -> UrpGen (A' (Make' IO)) () -> Make UWLib
uwlib urpfile m = do
(_,u) <- rule2 $ do
((),s) <- runStateT (unUrpGen m) (defState urpfile)
let u@(Urp _ _ hdr mod) = urpst s
let up = urpUp urpfile
toFile urpfile $ do
forM hdr (line . toUrpLine up)
line ""
forM mod (line . toUrpLine up)
forM_ (urpObjs u) $ \o -> do
let incl = makevar "URINCL" "$(shell urweb -print-cinclude)"
let cc = makevar "URCC" "$(shell $(shell urweb -print-ccompiler) -print-prog-name=gcc)"
rule2 $ do
shell [cmd| $cc c I $incl o @o $(o .= "c") |]
depend (urpDeps u)
depend (urpLibs u)
shell [cmd|touch @urpfile|]
return u
return $ UWLib u
uwapp :: String -> File -> UrpGen (A' (Make' IO)) () -> Make UWExe
uwapp opts urpfile m = do
(UWLib u') <- uwlib urpfile m
let u = u' { uexe = Just (urpfile .= "exe") }
rule $ do
depend urpfile
produce (urpExe u)
case urpSql' u of
Nothing -> return ()
Just sql -> produce sql
unsafeShell [cmd|urweb $(string opts) $((takeDirectory urpfile)</>(takeBaseName urpfile))|]
return $ UWExe u
liftUrp m = m
addHdr h = modify $ \s -> let u = urpst s in s { urpst = u { uhdr = (uhdr u) ++ [h] } }
addMod m = modify $ \s -> let u = urpst s in s { urpst = u { umod = (umod u) ++ [m] } }
database :: (MonadMake m) => String -> UrpGen m ()
database dbs = addHdr $ UrpDatabase dbs
allow :: (MonadMake m) => UrpAllow -> String -> UrpGen m ()
allow a s = addHdr $ UrpAllow a s
rewrite :: (MonadMake m) => UrpRewrite -> String -> UrpGen m ()
rewrite a s = addHdr $ UrpRewrite a s
urpUp :: File -> FilePath
urpUp f = F.joinPath $ map (const "..") $ filter (/= ".") $ F.splitDirectories $ F.takeDirectory $ toFilePath f
newtype UrEmbed = Urembed File
deriving (Show)
data UrpLibReference
= UrpLibStandalone File
| UrpLibInternal UWLib
| UrpLibEmbed UrEmbed
deriving(Show)
library' :: (MonadMake m) => File -> UrpGen m ()
library' l = do
when ((takeExtension l) /= ".urp") $ do
fail "library declaration for %s should ends with '.urp'" (toFilePath l)
addHdr $ UrpLibrary l
library :: (MonadMake m) => UrpLibReference -> UrpGen m ()
library (UrpLibStandalone l) = do
library' l
when ((toFilePath $ takeDirectory l) /= ".") $ do
prebuild [cmd| $(make) C $(takeDirectory l) |]
library (UrpLibInternal (UWLib u)) = library' (urp u)
library (UrpLibEmbed ue) = error "urembed is not defined"
standalone f = UrpLibStandalone f
internal u = UrpLibInternal u
embed e = UrpLibEmbed e
module_ :: (MonadMake m) => UrpModToken -> UrpGen m ()
module_ = addMod
pair f = UrpModule2 (f.="ur") (f.="urs")
single f = UrpModule1 f
sys s = UrpModuleSys s
debug :: (MonadMake m) => UrpGen m ()
debug = addHdr $ UrpDebug
include :: (MonadMake m) => File -> UrpGen m ()
include f = addHdr $ UrpInclude f
link :: (MonadMake m) => File -> UrpGen m ()
link f = addHdr $ UrpLink f
ffi :: (MonadMake m) => File -> UrpGen m ()
ffi s = addHdr $ UrpFFI s
sql :: (MonadMake m) => File -> UrpGen m ()
sql f = addHdr $ UrpSql f
jsFunc n s = addHdr $ UrpJSFunc n s
safeGet s = addHdr $ UrpSafeGet s
url = UrpUrl
mime = UrpMime
style = UrpStyle
guessMime inf = fixup $ BS.unpack (defaultMimeLookup (fromString inf)) where
fixup "application/javascript" = "text/javascript"
fixup m = m
data JSFunc = JSFunc {
urdecl :: String
, urname :: String
, jsname :: String
} deriving(Show)
data JSType = JSType {
urtdecl :: String
} deriving(Show)
parse_js :: BS.ByteString -> Make (Either String ([JSType],[JSFunc]))
parse_js contents = do
runErrorT $ do
c <- either fail return (parse (BS.unpack contents) "<urembed_input>")
f <- concat <$> (forM (findTopLevelFunctions c) $ \f@(fn:_) -> (do
ts <- mapM extractEmbeddedType (f`zip`(False:repeat True))
let urdecl_ = urs_line ts
let urname_ = (fst (head ts))
let jsname_ = fn
return [JSFunc urdecl_ urname_ jsname_]
) `catchError` (\(e::String) -> do
err $ printf "ignoring function %s, reason:\n\t%s" fn e
return []))
t <- concat <$> (forM (findTopLevelVars c) $ \vn -> (do
(n,t) <- extractEmbeddedType (vn,False)
return [JSType $ printf "type %s" t]
)`catchError` (\(e::String) -> do
err $ printf "ignoring variable %s, reason:\n\t%s" vn e
return []))
return (t,f)
where
urs_line :: [(String,String)] -> String
urs_line [] = error "wrong function signature"
urs_line ((n,nt):args) = printf "val %s : %s" n (fmtargs args) where
fmtargs :: [(String,String)] -> String
fmtargs ((an,at):as) = printf "%s -> %s" at (fmtargs as)
fmtargs [] = let pf = L.stripPrefix "pure_" nt in
case pf of
Just p -> p
Nothing -> printf "transaction %s" nt
extractEmbeddedType :: (Monad m) => (String,Bool) -> m (String,String)
extractEmbeddedType ([],_) = error "BUG: empty identifier"
extractEmbeddedType (name,fallback) = check (msum [span2 "__" name , span2 "_as_" name]) where
check (Just (n,t)) = return (n,t)
check _ | fallback == True = return (name,name)
| fallback == False = fail $ printf "Can't extract the type from the identifier '%s'" name
findTopLevelFunctions :: JSNode -> [[String]]
findTopLevelFunctions top = map decls $ listify is_func top where
is_func n@(JSFunction a b c d e f) = True
is_func _ = False
decls (JSFunction a b c d e f) = (identifiers b) ++ (identifiers d)
findTopLevelVars :: JSNode -> [String]
findTopLevelVars top = map decls $ listify is_var top where
is_var n@(JSVarDecl a []) = True
is_var _ = False
decls (JSVarDecl a _) = (head $ identifiers a);
identifiers x = map name $ listify ids x where
ids i@(JSIdentifier s) = True
ids _ = False
name (JSIdentifier n) = n
err,out :: (MonadIO m) => String -> m ()
err = hio stderr
out = hio stdout
span2 :: String -> String -> Maybe (String,String)
span2 inf s = span' [] s where
span' _ [] = Nothing
span' acc (c:cs)
| L.isPrefixOf inf (c:cs) = Just (acc, drop (length inf) (c:cs))
| otherwise = span' (acc++[c]) cs
hio :: (MonadIO m) => Handle -> String -> m ()
hio h = liftIO . hPutStrLn h
bin :: (MonadIO m, MonadMake m) => File -> File -> UrpGen m ()
bin dir src = do
c <- readFileForMake src
bin' dir (toFilePath src) c
bin' :: (MonadIO m, MonadMake m) => File -> FilePath -> BS.ByteString -> UrpGen m ()
bin' dir src_name src_contents = do
let mime = guessMime src_name
let mn = (mkname src_name)
let wrapmod ext = (dir </> mn) .= ext
let binmod ext = (dir </> (mn ++ "_c")) .= ext
let jsmod ext = (dir </> (mn ++ "_js")) .= ext
let binfunc = printf "uw_%s_binary" (modname binmod)
let textfunc = printf "uw_%s_text" (modname binmod)
toFile (binmod ".c") $ do
line $ "/* Thanks, http://stupefydeveloper.blogspot.ru/2008/08/cc-embed-binary-data-into-elf.html */"
line $ "#include <urweb.h>"
line $ "#include <stdio.h>"
line $ printf "#define BLOBSZ %d" (BS.length src_contents)
line $ "static char blob[BLOBSZ];"
line $ "uw_Basis_blob " ++ binfunc ++ " (uw_context ctx, uw_unit unit)"
line $ "{"
line $ " uw_Basis_blob uwblob;"
line $ " uwblob.data = &blob[0];"
line $ " uwblob.size = BLOBSZ;"
line $ " return uwblob;"
line $ "}"
line $ ""
line $ "uw_Basis_string " ++ textfunc ++ " (uw_context ctx, uw_unit unit) {"
line $ " char* data = &blob[0];"
line $ " size_t size = sizeof(blob);"
line $ " char * c = uw_malloc(ctx, size+1);"
line $ " char * write = c;"
line $ " int i;"
line $ " for (i = 0; i < size; i++) {"
line $ " *write = data[i];"
line $ " if (*write == '\\0')"
line $ " *write = '\\n';"
line $ " *write++;"
line $ " }"
line $ " *write=0;"
line $ " return c;"
line $ " }"
line $ ""
let append f wr = liftIO $ BS.appendFile f $ execWriter $ wr
append (toFilePath (binmod ".c")) $ do
let line s = tell ((BS.pack s)`mappend`(BS.pack "\n"))
line $ ""
line $ "static char blob[BLOBSZ] = {"
let buf = reverse $ BS.foldl (\a c -> (BS.pack (printf "0x%02X ," c)) : a) [] src_contents
tell (BS.concat buf)
line $ "};"
line $ ""
toFile (binmod ".h") $ do
line $ "#include <urweb.h>"
line $ "uw_Basis_blob " ++ binfunc ++ " (uw_context ctx, uw_unit unit);"
line $ "uw_Basis_string " ++ textfunc ++ " (uw_context ctx, uw_unit unit);"
toFile (binmod ".urs") $ do
line $ "val binary : unit -> transaction blob"
line $ "val text : unit -> transaction string"
include (binmod ".h")
link (binmod ".o")
ffi (binmod ".urs")
(jstypes,jsdecls) <- if ((takeExtension src_name) == ".js") then do
e <- liftMake $ parse_js src_contents
case e of
Left e -> do
fail $ printf "Error while parsing %s" src_name
Right decls -> do
return decls
else
return ([],[])
toFile (jsmod ".urs") $ do
forM_ jstypes $ \decl -> line (urtdecl decl)
forM_ jsdecls $ \decl -> line (urdecl decl)
toFile (wrapmod ".urs") $ do
line $ "val binary : unit -> transaction blob"
line $ "val text : unit -> transaction string"
line $ "val blobpage : unit -> transaction page"
line $ "val geturl : url"
forM_ jstypes $ \decl -> line (urtdecl decl)
forM_ jsdecls $ \d -> line (urdecl d)
toFile (wrapmod ".ur") $ do
line $ "val binary = " ++ modname binmod ++ ".binary"
line $ "val text = " ++ modname binmod ++ ".text"
forM_ jsdecls $ \d ->
line $ printf "val %s = %s.%s" (urname d) (modname jsmod) (urname d)
line $ printf "fun blobpage {} = b <- binary () ; returnBlob b (blessMime \"%s\")" mime
line $ "val geturl = url(blobpage {})"
forM_ jsdecls $ \decl -> do
jsFunc (printf "%s.%s = %s" (modname jsmod) (urname decl)) (jsname decl)
ffi (jsmod ".urs")
safeGet $ printf "%s/blobpage" (modname wrapmod)
safeGet $ printf "%s/blob" (modname wrapmod)
module_ (pair $ wrapmod ".ur")
where
mkname :: FilePath -> String
mkname = upper1 . notnum . map under . takeFileName where
under c | c`elem`"_-. /" = '_'
| otherwise = c
upper1 [] = []
upper1 (x:xs) = (toUpper x) : xs
notnum n@(x:xs) | isDigit x = "f" ++ n
| otherwise = n
modname :: (String -> File) -> String
modname f = upper1 . takeBaseName $ f ".urs" where
upper1 [] = []
upper1 (x:xs) = (toUpper x) : xs