Permalink
Browse files

Implemented simple main shell program. It's BROKEN!

  • Loading branch information...
1 parent 22ac75f commit 94a30a75e1ff531d8c5f2d6ee16a27ac46dc270f @luqui committed Nov 19, 2008
View
@@ -0,0 +1,94 @@
+module Main where
+
+import Prelude hiding (log)
+import UdonShell.FST
+import UdonShell.FSDB
+import Udon.API
+import System.Environment
+import Data.Maybe (fromJust)
+import Control.Applicative
+import Control.Monad (when)
+import Data.Binary
+import System.IO
+import qualified Data.ByteString.Lazy as Str
+import qualified Data.Map as Map
+
+type Pad = Map.Map String DynRef
+
+padType = makeDynType (undefined :: Pad)
+fileType = makeDynType (undefined :: Str.ByteString)
+
+fstDir :: IO FilePath
+fstDir = do
+ dir <- getEnv "UDON_DIR"
+ when (null dir) $ fail "Environment variable UDON_DIR not set"
+ return dir
+
+log :: String -> IO a -> IO a
+log msg io = putStrLn msg >> io
+
+cmdInit :: [String] -> IO ()
+cmdInit [] = do
+ dir <- fstDir
+ log ("Creating udon repository at " ++ dir) $ do
+ makeFSTDir dir
+ runFST dir $ do
+ paddyn <- makeDynRef fsdb padType (makeExtRef Map.empty)
+ exp <- exportDyn fsdb paddyn
+ newFile ["ROOTPAD"] (encode exp)
+
+rootPadOp :: (Pad -> FST (a, Maybe Pad)) -> FST a
+rootPadOp f = do
+ exp <- decode <$> UdonShell.FST.readFile ["ROOTPAD"]
+ paddyn <- fromJust <$> readExportDyn fsdb exp
+ let pad = fromJust $ dynRefToExtRef padType paddyn
+ (ret,mpad') <- f =<< runExt fsdb (deref pad)
+ case mpad' of
+ Nothing -> return ret
+ Just pad' -> do
+ paddyn' <- makeDynRef fsdb padType (makeExtRef pad')
+ exp' <- exportDyn fsdb paddyn'
+ newFile ["ROOTPAD"] (encode exp')
+ return ret
+
+cmdLet :: [String] -> IO ()
+cmdLet [varname, filename] = do
+ dir <- fstDir
+ contents <- Str.readFile filename
+ runFST dir . rootPadOp $ \pad -> do
+ dat <- makeDynRef fsdb fileType (makeExtRef contents)
+ return ((), Just $ Map.insert varname dat pad)
+
+cmdLs :: [String] -> IO ()
+cmdLs [] = do
+ dir <- fstDir
+ list <- runFST dir . rootPadOp $ \pad -> return (Map.keys pad, Nothing)
+ mapM_ putStrLn list
+
+cmdShow :: [String] -> IO ()
+cmdShow [varname] = do
+ dir <- fstDir
+ mcontents <- runFST dir . rootPadOp $ \pad -> do
+ let mdyn = Map.lookup varname pad
+ r <- case mdyn of
+ Nothing -> return (Left $ "No such root pad entry " ++ varname)
+ Just dyn -> do
+ case dynRefToExtRef fileType dyn of
+ Nothing -> return (Left "Pad entry does not have correct type")
+ Just extref -> do
+ Right <$> runExt fsdb (deref extref)
+ return (r, Nothing)
+ case mcontents of
+ Left errmsg -> hPutStrLn stderr $ "*** Error: " ++ errmsg ++ "\n"
+ Right content -> Str.putStr content
+
+
+main = do
+ args <- getArgs
+ case args of
+ [] -> putStrLn "Commands: init, let, ls, show"
+ ("init":cmdargs) -> cmdInit cmdargs
+ ("let":cmdargs) -> cmdLet cmdargs
+ ("ls":cmdargs) -> cmdLs cmdargs
+ ("show":cmdargs) -> cmdShow cmdargs
+ _ -> putStrLn "Unknown command"
@@ -2,19 +2,27 @@ module UdonShell.FSDB (fsdb) where
import Udon.DBAPI
import qualified UdonShell.FST as FST
+import Debug.Trace
hashToPath h = [showHash h]
+debug s = trace s $ return ()
+
fsdb :: Database FST.FST
fsdb = Database {
fetch = \h -> do
let file = hashToPath h
exists <- FST.checkFile file
+ debug $ "Request " ++ showHash h ++ "... " ++ (if exists then "found" else "not found")
return $ if exists
then Just $ FST.readFile file
else Nothing,
- store = \h blob -> FST.newFile (hashToPath h) blob,
- export = \h -> return ()
+ store = \h blob -> do
+ debug $ "Store " ++ showHash h
+ FST.newFile (hashToPath h) blob,
+ export = \h -> do
+ debug $ "Export " ++ showHash h
+ return ()
}
@@ -1,3 +1,5 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
module UdonShell.FST
( FST, makeFSTDir, runFST
, Path, newFile, checkFile, readFile, deleteFile
@@ -38,12 +40,12 @@ makePath path = do
prefix <- ask
let dir = prefix ++ intercalate "/" (init path)
liftIO $ createDirectoryIfMissing True dir
- return $ dir ++ last path
+ return $ dir ++ "/" ++ last path
getPath :: Path -> FSTInternal FilePath
getPath path = do
prefix <- ask
- return $ prefix ++ intercalate "/" path
+ return $ prefix ++ "/" ++ intercalate "/" path
newFile :: Path -> Str.ByteString -> FST ()
newFile path content = FST $ do
@@ -1,23 +0,0 @@
-module UdonShell.Pad
- (Pad, insert, delete, lookup)
-where
-
-import Data.Typeable
-import Prelude hiding (lookup)
-import Udon.API
-import qualified Udon.DescCombinators as D
-import qualified Data.Map as Map
-
-newtype Pad = Pad { unPad :: Map.Map String DynRef }
- deriving (Typeable, Data)
-
-conj f = Pad . f . unPad
-
-insert :: String -> DynRef -> Pad -> Pad
-insert str ref = conj (Map.insert str ref)
-
-delete :: String -> Pad -> Pad
-delete str = conj (Map.delete str)
-
-lookup :: Pad -> String -> Maybe DynRef
-lookup (Pad pad) str = Map.lookup str pad
@@ -10,6 +10,6 @@ Category: Data
Author: Luke Palmer
Maintainer: lrpalmer@gmail.com
Build-Type: Simple
-Build-Depends: base, udon
executable udon
+ Build-Depends: base, containers, bytestring, mtl, directory, binary, udon
Main-Is: Main.hs
View
@@ -1,5 +1,5 @@
module Udon.API
- ( Database, writeData, makeDynRef, exportDyn
+ ( Database, writeData, makeDynRef, exportDyn, readExportDyn
, ExtRef, makeExtRef
, DataDesc, Data(..) -- Udon.DescCombinators has the rest
, DynType, makeDynType
View
@@ -3,6 +3,7 @@ module Udon.Database
, writeData
, makeDynRef
, exportDyn
+ , readExportDyn
, markAlive
)
where
@@ -12,6 +13,7 @@ import Udon.Chunk
import Udon.DataDesc
import Udon.DynRef
import Data.Binary
+import Control.Monad (liftM)
import qualified Data.Set as Set
import qualified Control.Monad.State as State
@@ -36,6 +38,9 @@ instance Binary ExportRef where
get = fmap ExportRef binHashGet
+fetch' :: (Monad m) => Database m -> Hash -> m (Maybe Blob)
+fetch' db hash =
+ maybe (return Nothing) (liftM Just) =<< fetch db hash
writeChunk :: (Monad m) => Database m -> Chunk -> m ()
writeChunk db chunk = store db (hashBlob enc) enc
@@ -95,3 +100,7 @@ exportDyn db dynref = do
-- so that it is treated as part of the root set for GC.
hash <- writeData db dynref
return (ExportRef hash)
+
+readExportDyn :: (Monad m) => Database m -> ExportRef -> m (Maybe DynRef)
+readExportDyn db (ExportRef hash) =
+ (liftM.liftM) (runChunkGet (ddRead desc) . decode) $ fetch' db hash
View
@@ -12,12 +12,14 @@ import Udon.DescInstances ()
type TypeID = String
newtype DynType a = DynType TypeID
+ deriving (Typeable)
-- Brittle!
makeDynType :: (Typeable a) => a -> DynType a
makeDynType = DynType . show . typeOf
data DynRef = DynRef TypeID Hash
+ deriving Typeable
instance Data DynRef where
desc = D.wrap (uncurry DynRef, \(DynRef tid h) -> (tid,h)) desc
View
@@ -5,7 +5,7 @@ where
import qualified Data.ByteString.Lazy as Str
import qualified Data.Digest.SHA256 as SHA
import Data.Binary
-import qualified Codec.Binary.Base64 as Base64
+import qualified Codec.Binary.Base64Url as Base64
type Blob = Str.ByteString
View
@@ -14,4 +14,4 @@ Build-Depends: base, binary, mtl, containers, bytestring, dataenc, Crypto
Exposed-Modules: Udon.API, Udon.DBAPI, Udon.DescCombinators
Other-Modules: Udon.Chunk, Udon.DataDesc, Udon.Database, Udon.DescInstances,
Udon.DynRef, Udon.External, Udon.Hash, Udon.Request
-Extensions:
+Extensions: DeriveDataTypeable

0 comments on commit 94a30a7

Please sign in to comment.