tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

Alias.hs (3269B)

      1 module ContentStore.Alias
      2   ( AliasKind(..)
      3   , ObjectRef(..)
      4   , aliasKindDirectory
      5   , validateAliasName
      6   , writeAlias
      7   , readAlias
      8   , listAliases
      9   ) where
     10 
     11 import ContentStore.Filesystem (ensureStore)
     12 import ContentStore.Object
     13 
     14 import Data.Char (isControl)
     15 import Data.Text (Text)
     16 import System.Directory (createDirectoryIfMissing, doesFileExist, listDirectory)
     17 import System.FilePath ((</>))
     18 
     19 import qualified Data.Text as Text
     20 import qualified Data.Text.IO as TextIO
     21 
     22 -- | Mutable workspace alias categories. Aliases are human-facing pointers to
     23 -- immutable content objects; they are not content identity.
     24 data AliasKind
     25   = NameAlias
     26   | ModuleAlias
     27   | PackageAlias
     28   deriving (Eq, Ord, Show)
     29 
     30 data ObjectRef = ObjectRef
     31   { objectRefKind :: Text
     32   , objectRefHash :: ObjectHash
     33   } deriving (Eq, Ord, Show)
     34 
     35 aliasKindDirectory :: AliasKind -> FilePath
     36 aliasKindDirectory NameAlias = "names"
     37 aliasKindDirectory ModuleAlias = "modules"
     38 aliasKindDirectory PackageAlias = "packages"
     39 
     40 -- | Aliases are single literal filename components, never paths. Keep qualified
     41 -- and symbolic language names; reject separators, drive/stream syntax and control
     42 -- characters rather than normalizing a dangerous name into a different alias.
     43 -- The selected store (including its directory/symlink structure) must be trusted.
     44 validateAliasName :: Text -> Either String ()
     45 validateAliasName name
     46   | Text.null name || name == "." || name == ".."
     47       || Text.any (\c -> c `elem` ("/\\:" :: String) || isControl c) name =
     48       Left $ "invalid alias name: " ++ show name
     49   | otherwise = Right ()
     50 
     51 writeAlias :: StorePath -> AliasKind -> Text -> ObjectRef -> IO ()
     52 writeAlias store@(StorePath root) kind name ref = do
     53   either fail pure (validateAliasName name)
     54   ensureStore store
     55   let dir = root </> "aliases" </> aliasKindDirectory kind
     56   createDirectoryIfMissing True dir
     57   TextIO.writeFile (dir </> Text.unpack name) (encodeObjectRef ref)
     58 
     59 readAlias :: StorePath -> AliasKind -> Text -> IO (Maybe ObjectRef)
     60 readAlias store@(StorePath root) kind name = do
     61   either fail pure (validateAliasName name)
     62   ensureStore store
     63   let path = root </> "aliases" </> aliasKindDirectory kind </> Text.unpack name
     64   exists <- doesFileExist path
     65   if not exists
     66     then return Nothing
     67     else decodeObjectRef <$> TextIO.readFile path
     68 
     69 listAliases :: StorePath -> AliasKind -> IO [(Text, ObjectRef)]
     70 listAliases store@(StorePath root) kind = do
     71   ensureStore store
     72   let dir = root </> "aliases" </> aliasKindDirectory kind
     73   names <- listDirectory dir
     74   fmap concat $ mapM load names
     75   where
     76     load name = do
     77       mRef <- readAlias store kind (Text.pack name)
     78       return $ maybe [] (\ref -> [(Text.pack name, ref)]) mRef
     79 
     80 encodeObjectRef :: ObjectRef -> Text
     81 encodeObjectRef ref = Text.unlines
     82   [ "kind: " <> objectRefKind ref
     83   , "hash: " <> objectRefHash ref
     84   ]
     85 
     86 decodeObjectRef :: Text -> Maybe ObjectRef
     87 decodeObjectRef txt = do
     88   kind <- lookupField "kind" fields
     89   hash <- lookupField "hash" fields
     90   return ObjectRef { objectRefKind = kind, objectRefHash = hash }
     91   where
     92     fields = map parseLine (Text.lines txt)
     93     parseLine line =
     94       let (k, rest) = Text.breakOn ":" line
     95       in (Text.strip k, Text.strip (Text.drop 1 rest))
     96     lookupField key = lookup key