src/Types.hs Modified

@@ -1,3 +1,4 @@
+{-# Language DerivingStrategies #-}
 {-# Language LambdaCase #-}
 {-# Language OverloadedStrings #-}
 {-# Language FlexibleInstances #-}  -- Needed for `instance ToGVal`
@@ -51,11 +52,16 @@
 data TreeFile = TreeFile
     { treeFilePath :: TreeFilePath
     , treeFileContents :: TreeFileContents
+    , treeFileMode :: TreeEntryMode
     }
 
-data TreeFileContents = FileContents (TreeEntryMode, Text) | FolderContents [TreeFilePath]
+data TreeFileContents = FileContents Text | FolderContents [TreeFilePath]
 
 data TreeEntryMode = ModeDirectory | ModePlain | ModeExecutable | ModeSymlink | ModeSubmodule
+    deriving stock Show
+
+showMode :: TreeEntryMode -> String
+showMode = drop 4 . show
 
 {-
 Some helper functions to convert from Haskell's LibGit2 BlobKind to our TreeEntryMode,
@@ -68,18 +74,18 @@
 blobkindToMode SymlinkBlob = ModeSymlink
 
 modeToOctal :: TreeEntryMode -> String
-modeToOctal ModeDirectory = "40000"
-modeToOctal ModePlain = "00644"
+modeToOctal ModeDirectory  = "40000"
+modeToOctal ModePlain      = "00644"
 modeToOctal ModeExecutable = "00755"
-modeToOctal ModeSymlink = "20000"
-modeToOctal ModeSubmodule = "60000"
+modeToOctal ModeSymlink    = "20000"
+modeToOctal ModeSubmodule  = "60000"
 
 modeToSymbolic :: TreeEntryMode -> String
-modeToSymbolic ModeDirectory = "drwxr-xr-x"
-modeToSymbolic ModePlain = "-rw-r--r--"
+modeToSymbolic ModeDirectory  = "drwxr-xr-x"
+modeToSymbolic ModePlain      = "-rw-r--r--"
 modeToSymbolic ModeExecutable = "-rwxr-xr-x"
-modeToSymbolic ModeSymlink = "l---------"
-modeToSymbolic ModeSubmodule = "git-module"
+modeToSymbolic ModeSymlink    = "l---------"
+modeToSymbolic ModeSubmodule  = "git-module"
 
 {-
 GVal implementations for data definitions above, allowing commits to be rendered in
@@ -95,7 +101,7 @@
 
 instance ToGVal m TreeFileContents where
     toGVal :: TreeFileContents -> GVal m
-    toGVal (FileContents (_, text)) = toGVal text
+    toGVal (FileContents text) = toGVal text
     toGVal (FolderContents filePaths) = def
         { asHtml = html . pack . show $ filePaths
         , asText = pack . show $ filePaths
@@ -107,6 +113,9 @@
     "path" -> Just . toGVal . treeFilePath $ treefile
     "href" -> Just . toGVal . treePathToHref . treeFilePath $ treefile
     "contents" -> Just . toGVal . treeFileContents $ treefile
+    "mode" -> Just . toGVal . show . treeFileMode $ treefile
+    "mode_octal" -> Just . toGVal . modeToOctal . treeFileMode $ treefile
+    "mode_symbolic" -> Just . toGVal . modeToSymbolic . treeFileMode $ treefile
     "is_directory" -> Just . toGVal . treeFileIsDirectory $ treefile
     _ -> Nothing
 

src/Repositories.hs Modified

@@ -110,6 +110,9 @@
     , ("tree", toGVal tree)
     ]
 
+{-
+Collect commit information.
+-}
 getCommits :: CommitOid LgRepo -> ReaderT LgRepo IO [Commit LgRepo]
 getCommits commitID =
     sequence . mapMaybe loadCommit <=<
@@ -119,17 +122,25 @@
 loadCommit (CommitObjOid oid) = Just $ lookupCommit oid
 loadCommit _ = Nothing
 
+{-
+Collect tree information.
+-}
 getTree :: CommitOid LgRepo -> ReaderT LgRepo IO [TreeFile]
 getTree commitID = do
     entries <- listTreeEntries =<< lookupTree . commitTree =<< lookupCommit commitID
-    contents <- mapM (gvalTreeEntry . snd) entries
-    return $ zipWith TreeFile (fmap fst entries) contents
-
-gvalTreeEntry :: TreeEntry LgRepo -> ReaderT LgRepo IO TreeFileContents
-gvalTreeEntry (BlobEntry oid kind) =
-    FileContents . (,) (blobkindToMode kind) . decodeUtf8With lenientDecode <$> catBlob oid
-gvalTreeEntry (TreeEntry oid) = FolderContents . fmap fst <$> (listTreeEntries =<< lookupTree oid)
-gvalTreeEntry (CommitEntry _) = return . FileContents $ (ModeSubmodule, "No contents")  -- TODO
+    contents <- mapM (getEntryContents . snd) entries
+    modes <- mapM (getEntryModes . snd) entries
+    return $ zipWith3 TreeFile (fmap fst entries) contents modes
+
+getEntryContents :: TreeEntry LgRepo -> ReaderT LgRepo IO TreeFileContents
+getEntryContents (BlobEntry oid _) = FileContents . decodeUtf8With lenientDecode <$> catBlob oid
+getEntryContents (TreeEntry oid) = FolderContents . fmap fst <$> (listTreeEntries =<< lookupTree oid)
+getEntryContents (CommitEntry oid) = return . FileContents . pack . show . untag $ oid
+
+getEntryModes :: TreeEntry LgRepo -> ReaderT LgRepo IO TreeEntryMode
+getEntryModes (BlobEntry _ kind) = return . blobkindToMode $ kind
+getEntryModes (TreeEntry _) = return ModeDirectory
+getEntryModes (CommitEntry _) = return ModeSubmodule
 
 ----------------------------------------------------------------------------------------
 -- Targets -----------------------------------------------------------------------------

README.rst Modified

@@ -39,6 +39,6 @@
 [ ] Expose license url in repo scope for convenient hyperlinking
 [ ] Expose repo branches and tags in repo scope
 [ ] Commit diffs
-[ ] Tree entry filemodes
+[x] Tree entry filemodes
 [ ] Generate RSS?
 [ ] Write guide in readme