-rw-r--r-- src/Types.hs
1 {-# LANGUAGE DerivingStrategies #-} 2 {-# LANGUAGE FlexibleInstances #-} 3 {-# LANGUAGE InstanceSigs #-} 4 {-# LANGUAGE LambdaCase #-} 5 {-# LANGUAGE MultiParamTypeClasses #-} 6 {-# LANGUAGE OverloadedStrings #-} 7 8 module Types where 9 10 import Bindings.Libgit2.Blob (c'git_blob_is_binary, c'git_blob_lookup) 11 import Control.Monad (when) 12 import Control.Monad.Catch (throwM) 13 import Control.Monad.IO.Class (liftIO) 14 import Control.Monad.Trans.Reader (ReaderT) 15 import Data.ByteString (ByteString) 16 import Data.Default (def) 17 import Data.Maybe (listToMaybe) 18 import Data.Tagged (untag) 19 import qualified Data.Text as T 20 import Data.Text.Encoding (decodeUtf8With) 21 import Data.Text.Encoding.Error (lenientDecode) 22 import Foreign (peek) 23 import Foreign.ForeignPtr (mallocForeignPtr, withForeignPtr) 24 import qualified Git 25 import Git.Libgit2 (LgRepo, getOid, repoObj) 26 import Path (Abs, Dir, Path, dirname, toFilePath) 27 import qualified System.FilePath as FP 28 import Text.Ginger.GVal (GVal, ToGVal, asBoolean, asHtml, asList, asLookup, asText, toGVal) 29 import Text.Ginger.Html (Html, html) 30 import Text.Ginger.Parse (SourcePos) 31 import Text.Ginger.Run (Run) 32 33 {- 34 Convenience type alias for the ginger run monad with git repo context. 35 -} 36 type RunRepo = Run SourcePos IO Html 37 38 unquote :: String -> String 39 unquote = init . tail 40 41 bsToText :: ByteString -> T.Text 42 bsToText = decodeUtf8With lenientDecode 43 44 {- 45 GVal implementation for a repository, accessed in the scope of an individual repository, 46 as well as in a list of all repositories in the index template. 47 -} 48 data Repo = Repo 49 { repositoryPath :: Path Abs Dir 50 , repositoryDescription :: T.Text 51 , repositoryHead :: Maybe Commit 52 } 53 54 instance ToGVal m (Path b t) where 55 toGVal :: Path b t -> GVal m 56 toGVal = toGVal . toFilePath 57 58 instance ToGVal m Repo where 59 toGVal :: Repo -> GVal m 60 toGVal repo = 61 def 62 { asHtml = html . T.pack . init . unquote . show . dirname . repositoryPath $ repo 63 , asText = T.pack . show . dirname . repositoryPath $ repo 64 , asLookup = Just . repoAsLookup $ repo 65 } 66 67 repoAsLookup :: Repo -> T.Text -> Maybe (GVal m) 68 repoAsLookup repo = \case 69 "name" -> Just . toGVal . init . unquote . show . dirname . repositoryPath $ repo 70 "description" -> Just . toGVal . repositoryDescription $ repo 71 "head" -> Just . toGVal . repositoryHead $ repo 72 "updated" -> toGVal . show . Git.signatureWhen . Git.commitCommitter . commitGit <$> repositoryHead repo 73 _ -> Nothing 74 75 {- 76 GVal implementation for commits, allowing them to be rendered in Ginger templates. 77 -} 78 data Commit = Commit 79 { commitGit :: Git.Commit LgRepo 80 , commitDiffs :: [Diff] 81 } 82 83 instance ToGVal m Commit where 84 toGVal :: Commit -> GVal m 85 toGVal commit = 86 def 87 { asHtml = html . T.strip . T.takeWhile (/= '\n') . Git.commitLog . commitGit $ commit 88 , asText = T.pack . show . Git.commitLog . commitGit $ commit 89 , asLookup = Just . commitAsLookup $ commit 90 } 91 92 commitAsLookup :: Commit -> T.Text -> Maybe (GVal m) 93 commitAsLookup commit = \case 94 "id" -> Just . toGVal . commitHash $ commit 95 "href" -> Just . toGVal . (<> ".html") . commitHash $ commit 96 "title" -> Just . toGVal . T.strip . T.takeWhile (/= '\n') . Git.commitLog . commitGit $ commit 97 "body" -> Just . toGVal . T.strip . T.dropWhile (/= '\n') . Git.commitLog . commitGit $ commit 98 "message" -> Just . toGVal . T.strip . Git.commitLog . commitGit $ commit 99 "author" -> Just . toGVal . T.strip . Git.signatureName . Git.commitAuthor . commitGit $ commit 100 "committer" -> Just . toGVal . T.strip . Git.signatureName . Git.commitCommitter . commitGit $ commit 101 "author_email" -> Just . toGVal . T.strip . Git.signatureEmail . Git.commitAuthor . commitGit $ commit 102 "committer_email" -> Just . toGVal . T.strip . Git.signatureEmail . Git.commitCommitter . commitGit $ commit 103 "authored" -> Just . toGVal . show . Git.signatureWhen . Git.commitAuthor . commitGit $ commit 104 "committed" -> Just . toGVal . show . Git.signatureWhen . Git.commitCommitter . commitGit $ commit 105 "encoding" -> Just . toGVal . T.strip . Git.commitEncoding . commitGit $ commit 106 "parent" -> toGVal . show . untag <$> (listToMaybe . Git.commitParents . commitGit $ commit) 107 "diffs" -> Just . toGVal . commitDiffs $ commit 108 _ -> Nothing 109 110 commitHash :: Commit -> String 111 commitHash = show . untag . Git.commitOid . commitGit 112 113 {- 114 With `Diff`s there is a hierarchy: 115 116 - A commit has multiple diffs - one per file that changed. 117 - Each diff has 1 or more hunks 118 - Each hunk has a number of lines 119 -} 120 data Diff = Diff 121 { diffNewFile :: Git.TreeFilePath 122 , diffOldFile :: Maybe Git.TreeFilePath 123 , diffStatus :: Delta 124 , diffHunks :: [Hunk] 125 } 126 127 data Delta 128 = Unmodified 129 | Added 130 | Deleted 131 | Modified 132 | Renamed 133 | Copied 134 | Ignored 135 | Untracked 136 | Typechange 137 deriving stock (Eq, Ord, Enum, Show) 138 139 type HunkHeader = ByteString 140 type DiffLine = ByteString 141 142 data Hunk = Hunk 143 { hunkHeader :: HunkHeader 144 , hunkLines :: [DiffLine] 145 } 146 147 instance ToGVal m Diff where 148 toGVal :: Diff -> GVal m 149 toGVal diff = 150 def 151 { asHtml = html . bsToText . diffNewFile $ diff 152 , asText = bsToText . diffNewFile $ diff 153 , asLookup = Just . diffAsLookup $ diff 154 } 155 156 diffAsLookup :: Diff -> T.Text -> Maybe (GVal m) 157 diffAsLookup diff = \case 158 "new_file" -> Just . toGVal . diffNewFile $ diff 159 "old_file" -> toGVal <$> diffOldFile diff 160 "status" -> Just . toGVal . show . diffStatus $ diff 161 "hunks" -> Just . toGVal . diffHunks $ diff 162 _ -> Nothing 163 164 instance ToGVal m Hunk where 165 toGVal :: Hunk -> GVal m 166 toGVal hunk = 167 def 168 { asHtml = html . bsToText . hunkHeader $ hunk 169 , asText = bsToText . hunkHeader $ hunk 170 , asLookup = Just . hunkAsLookup $ hunk 171 } 172 173 hunkAsLookup :: Hunk -> T.Text -> Maybe (GVal m) 174 hunkAsLookup hunk = \case 175 "lines" -> Just . toGVal . fmap makeLine . hunkLines $ hunk 176 "header" -> Just . toGVal . bsToText . hunkHeader $ hunk 177 _ -> Nothing 178 where 179 makeLine :: DiffLine -> Line 180 makeLine line = 181 let text = bsToText line 182 in Line text (cls . T.head $ text) 183 184 cls :: Char -> String 185 cls = \case 186 '+' -> "add" 187 '-' -> "sub" 188 _ -> "def" 189 190 {- 191 Wrap diff lines when accessed so that they can each get a class string indicating 192 whether they are additions, subtractions, or context lines. They are primarily a 193 convenience for assigning CSS classes. 194 -} 195 data Line = Line 196 { lineText :: T.Text 197 , lineClass :: String 198 } 199 200 instance ToGVal m Line where 201 toGVal :: Line -> GVal m 202 toGVal line = 203 def 204 { asHtml = html . lineText $ line 205 , asText = lineText line 206 , asLookup = Just . lineAsLookup $ line 207 } 208 209 lineAsLookup :: Line -> T.Text -> Maybe (GVal m) 210 lineAsLookup line = \case 211 "text" -> Just . toGVal . lineText $ line 212 "class" -> Just . toGVal . lineClass $ line 213 _ -> Nothing 214 215 {- 216 Next we have some data used to represent a repository's tree and the different kinds of 217 objects contained therein. A TreeEntry is any single entry found in a git tree object - 218 a blob, a nested tree, or a commit (submodule reference). 219 -} 220 data TreeEntry = TreeEntry 221 { treeEntryPath :: T.Text 222 , treeEntryContents :: TreeEntryContents 223 , treeEntryMode :: TreeEntryMode 224 } 225 226 data TreeEntryContents = BinaryContents | FileContents ByteString | FolderContents [TreeEntry] 227 228 data TreeEntryMode = ModeDirectory | ModePlain | ModeExecutable | ModeSymlink | ModeSubmodule 229 deriving stock (Show) 230 231 {- 232 Some helper functions to convert from Haskell's LibGit2 BlobKind to our TreeEntryMode, 233 and then from that to Git's octal representation, as seen when calling `git ls-tree 234 <tree-ish>` 235 -} 236 blobkindToMode :: Git.BlobKind -> TreeEntryMode 237 blobkindToMode Git.PlainBlob = ModePlain 238 blobkindToMode Git.ExecutableBlob = ModeExecutable 239 blobkindToMode Git.SymlinkBlob = ModeSymlink 240 241 {- 242 This 243 -} 244 getBlobContents :: Git.BlobOid LgRepo -> ReaderT LgRepo IO TreeEntryContents 245 getBlobContents oid = do 246 repo <- Git.getRepository 247 blobPtr <- liftIO mallocForeignPtr 248 isBinary <- liftIO . withForeignPtr (repoObj repo) $ \repoPtr -> 249 withForeignPtr blobPtr $ \blobPtr' -> 250 withForeignPtr (getOid . untag $ oid) $ \oidPtr -> do 251 r1 <- c'git_blob_lookup blobPtr' repoPtr oidPtr 252 when (r1 < 0) $ throwM (Git.BackendError "Could not lookup blob") 253 c'git_blob_is_binary =<< peek blobPtr' 254 255 if toEnum . fromEnum $ isBinary -- This reads weird, but it goes CInt, to Int, to Bool. 256 then return BinaryContents 257 else FileContents <$> Git.catBlob oid 258 259 {- 260 GVal implementations for data definitions above, allowing commits to be rendered in 261 Ginger templates. 262 -} 263 instance ToGVal m TreeEntry where 264 toGVal :: TreeEntry -> GVal m 265 toGVal treeentry = 266 def 267 { asHtml = html . treeEntryPath $ treeentry 268 , asText = treeEntryPath treeentry 269 , asLookup = Just . treeAsLookup $ treeentry 270 , asBoolean = True -- Used for conditionally checking readme/license template variables. 271 } 272 273 instance ToGVal m TreeEntryContents where 274 toGVal :: TreeEntryContents -> GVal m 275 toGVal BinaryContents = def 276 toGVal (FileContents bytestring) = toGVal bytestring 277 toGVal (FolderContents treeEntries) = 278 def 279 { asHtml = html . T.pack . show . fmap treeEntryPath $ treeEntries 280 , asText = T.pack . show . fmap treeEntryPath $ treeEntries 281 , asList = Just . fmap toGVal $ treeEntries 282 } 283 284 {- 285 Recursively descend into a tree, keeping every entry along the way - blobs and trees 286 alike - as a single flat list. Equivalent to `git ls-tree -r -t`. 287 -} 288 flattenTree :: TreeEntry -> [TreeEntry] 289 flattenTree treeentry = case treeEntryContents treeentry of 290 FolderContents entries -> treeentry : concatMap flattenTree entries 291 _ -> [treeentry] 292 293 treeAsLookup :: TreeEntry -> T.Text -> Maybe (GVal m) 294 treeAsLookup treeentry = \case 295 "path" -> Just . toGVal . treeEntryPath $ treeentry 296 "name" -> Just . toGVal . FP.takeFileName . T.unpack . treeEntryPath $ treeentry 297 "href" -> Just . toGVal . treePathToHref $ treeentry 298 "contents" -> Just . toGVal . treeEntryContents $ treeentry 299 "tree" -> Just . toGVal . treeEntryGetTree . treeEntryContents $ treeentry 300 "entries" -> Just . toGVal . concatMap flattenTree . treeEntryGetTree . treeEntryContents $ treeentry 301 "mode" -> Just . toGVal . drop 4 . show . treeEntryMode $ treeentry 302 "mode_octal" -> Just . toGVal . modeToOctal . treeEntryMode $ treeentry 303 "mode_symbolic" -> Just . toGVal . modeToSymbolic . treeEntryMode $ treeentry 304 "is_binary" -> Just . toGVal . treeEntryIsBinary $ treeentry 305 "is_directory" -> Just . toGVal . treeEntryIsDirectory $ treeentry 306 _ -> Nothing 307 where 308 -- The entries of this tree object - i.e. this directory's immediate children. 309 treeEntryGetTree :: TreeEntryContents -> [TreeEntry] 310 treeEntryGetTree (FolderContents fs) = fs 311 treeEntryGetTree _ = [] 312 313 treeEntryIsBinary :: TreeEntry -> Bool 314 treeEntryIsBinary treeentry' = case treeEntryContents treeentry' of 315 BinaryContents -> True 316 _ -> False 317 318 treeEntryIsDirectory :: TreeEntry -> Bool 319 treeEntryIsDirectory treeentry' = case treeEntryContents treeentry' of 320 FolderContents _ -> True 321 _ -> False 322 323 modeToOctal :: TreeEntryMode -> String 324 modeToOctal ModeDirectory = "40000" 325 modeToOctal ModePlain = "00644" 326 modeToOctal ModeExecutable = "00755" 327 modeToOctal ModeSymlink = "20000" 328 modeToOctal ModeSubmodule = "60000" 329 330 modeToSymbolic :: TreeEntryMode -> String 331 modeToSymbolic ModeDirectory = "drwxr-xr-x" 332 modeToSymbolic ModePlain = "-rw-r--r--" 333 modeToSymbolic ModeExecutable = "-rwxr-xr-x" 334 modeToSymbolic ModeSymlink = "l---------" 335 modeToSymbolic ModeSubmodule = "git-module" 336 337 {- 338 Get the name of a tree entry path's HTML file. Leading periods are dropped. 339 -} 340 treePathToHref :: TreeEntry -> T.Text 341 treePathToHref = T.dropWhile (== '.') . flip T.append ".html" . T.replace "/" "." . treeEntryPath 342 343 {- 344 Data to store information about references: tags and branches. 345 -} 346 data Ref = Ref 347 { refName :: Git.RefName 348 , refCommit :: Commit 349 } 350 351 instance ToGVal m Ref where 352 toGVal :: Ref -> GVal m 353 toGVal ref = 354 def 355 { asHtml = html . refName $ ref 356 , asText = refName ref 357 , asLookup = Just . refAsLookup $ ref 358 } 359 360 refAsLookup :: Ref -> T.Text -> Maybe (GVal m) 361 refAsLookup ref = \case 362 "name" -> Just . toGVal . refName $ ref 363 "commit" -> Just . toGVal . refCommit $ ref 364 key -> commitAsLookup (refCommit ref) key 365