Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Implemented simple main shell program. It's BROKEN!
  • Loading branch information
luqui committed Nov 19, 2008
1 parent 22ac75f commit 94a30a7
Show file tree
Hide file tree
Showing 10 changed files with 123 additions and 31 deletions.
94 changes: 94 additions & 0 deletions udon-shell/Main.hs
@@ -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"
12 changes: 10 additions & 2 deletions udon-shell/UdonShell/FSDB.hs
Expand Up @@ -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 ()
}


6 changes: 4 additions & 2 deletions udon-shell/UdonShell/FST.hs
@@ -1,3 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module UdonShell.FST
( FST, makeFSTDir, runFST
, Path, newFile, checkFile, readFile, deleteFile
Expand Down Expand Up @@ -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
Expand Down
23 changes: 0 additions & 23 deletions udon-shell/UdonShell/Pad.hs

This file was deleted.

2 changes: 1 addition & 1 deletion udon-shell/udon-shell.cabal
Expand Up @@ -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
2 changes: 1 addition & 1 deletion udon/Udon/API.hs
@@ -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
Expand Down
9 changes: 9 additions & 0 deletions udon/Udon/Database.hs
Expand Up @@ -3,6 +3,7 @@ module Udon.Database
, writeData
, makeDynRef
, exportDyn
, readExportDyn
, markAlive
)
where
Expand All @@ -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

Expand All @@ -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
Expand Down Expand Up @@ -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
2 changes: 2 additions & 0 deletions udon/Udon/DynRef.hs
Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion udon/Udon/Hash.hs
Expand Up @@ -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

Expand Down
2 changes: 1 addition & 1 deletion udon/udon.cabal
Expand Up @@ -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.