-rw-r--r-- src/Repositories.hs
1 {-# LANGUAGE BlockArguments #-} 2 {-# LANGUAGE FlexibleContexts #-} 3 {-# LANGUAGE FlexibleInstances #-} 4 {-# LANGUAGE LambdaCase #-} 5 {-# LANGUAGE OverloadedStrings #-} 6 {-# LANGUAGE ScopedTypeVariables #-} 7 {-# LANGUAGE NoMonomorphismRestriction #-} 8 9 module Repositories ( 10 run, 11 ) where 12 13 import qualified Bindings.Libgit2 as LG 14 import Conduit (runConduit, sinkList, (.|)) 15 import Control.Exception (try) 16 import Control.Monad (filterM, unless, when, (<=<)) 17 import Control.Monad.Extra (ifM, whenJust) 18 import Control.Monad.IO.Unlift 19 import Control.Monad.Trans.Reader (ReaderT) 20 import Data.Bool (bool) 21 import qualified Data.ByteString as B 22 import qualified Data.ByteString.UTF8 as B 23 import Data.Either (isRight) 24 import qualified Data.HashMap.Strict as HashMap 25 import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef) 26 import Data.List (find) 27 import Data.Maybe (catMaybes, fromJust, listToMaybe, mapMaybe) 28 import Data.Tagged (Tagged (..), untag) 29 import qualified Data.Text as T 30 import qualified Data.Text.Encoding as T 31 import qualified Data.Text.Encoding.Error as T 32 import qualified Data.Text.Lazy.IO as TL 33 import Foreign.C.String (CString) 34 import Foreign.C.Types (CChar, CFloat, CInt, CSize) 35 import Foreign.Ptr (Ptr) 36 import Foreign.Storable (peek) 37 import qualified Git 38 import Git.Libgit2 (LgRepo, lgDiffTreeToTree, lgFactory) 39 import Path (Abs, Dir, Path, Rel, dirname, parseRelDir, parseRelFile, toFilePath, (</>)) 40 import Path.IO (doesFileExist, ensureDir) 41 import qualified System.Directory as D 42 import qualified System.FilePath as FP 43 import Text.Ginger.GVal (GVal, ToGVal, toGVal) 44 45 import Env (Env (..)) 46 import Templates (Template (..), render) 47 import Types 48 49 {- 50 This is the entrypoint that maps over our repositories, reading from them and writing 51 out their web pages using the loaded templates. 52 -} 53 run :: Env -> IO [Repo] 54 run env = do 55 repos <- loadRepos env 56 mapM (processRepo env repos) repos 57 58 {- 59 Get paths along with their descriptions. 60 -} 61 loadRepos :: Env -> IO [Repo] 62 loadRepos = mapM mkRepo <=< filterM (fmap isRight . okRepo) . envRepos 63 where 64 okRepo :: Path Abs Dir -> IO (Either Git.GitException LgRepo) 65 okRepo p = 66 try . liftIO . Git.openRepository lgFactory $ 67 Git.defaultRepositoryOptions{Git.repoPath = toFilePath p} 68 69 mkRepo :: Path Abs Dir -> IO Repo 70 mkRepo p = (\d -> Repo p d Nothing) <$> getDescription p 71 72 {- 73 Pass the repository's folder, get its description. The approach is: 74 75 1. Check for a description in repo/description 76 2. Check for a description in repo/.git/description 77 3. Fallback to the repo folder's name. 78 79 -} 80 getDescription :: Path Abs Dir -> IO T.Text 81 getDescription dir = 82 ifM 83 (D.doesFileExist inTop) 84 (return . Just $ inTop) 85 ( ifM 86 (D.doesFileExist inGit) 87 (return . Just $ inGit) 88 (return Nothing) 89 ) 90 >>= \case 91 Just file -> 92 T.strip . T.pack <$> readFile file 93 Nothing -> 94 return . T.pack . toFilePath . dirname $ dir 95 where 96 inTop = toFilePath dir FP.</> "description" 97 inGit = toFilePath dir FP.</> ".git" FP.</> "description" 98 99 {- 100 This receives a file path to a single repository and tries to process it. If the 101 repository doesn't exist or is unreadable in any way we can forget about it and move on 102 (after informing the user of course). 103 -} 104 processRepo :: Env -> [Repo] -> Repo -> IO Repo 105 processRepo env repos repo = 106 Git.withRepository lgFactory (toFilePath . repositoryPath $ repo) $ processRepo' env repos repo 107 108 processRepo' :: Env -> [Repo] -> Repo -> ReaderT LgRepo IO Repo 109 processRepo' env repos repo = do 110 let name = dirname . repositoryPath $ repo 111 let directory = envOutput env </> name 112 113 Git.resolveReference "HEAD" >>= \case 114 Nothing -> do 115 liftIO . unless (envQuiet env) . putStrLn $ "gitja: " <> show name <> ": Failed to resolve HEAD." 116 return repo 117 Just commitID -> do 118 let gitHead = Tagged commitID 119 headCommit <- loadDiff =<< Git.lookupCommit gitHead 120 121 -- If a page exists for the head commit, don't do anything else -- 122 exists <- 123 liftIO . D.doesFileExist $ 124 toFilePath directory FP.</> "commit" FP.</> show commitID <> ".html" 125 126 when (not exists || envForce env) $ do 127 -- Collect variables available to the ginger templates -- 128 commits <- getCommits gitHead 129 tree <- getTree gitHead 130 let scope = package env repos name (repositoryDescription repo) commits tree 131 132 withRunInIO \runInIO -> do 133 -- Create the destination folders -- 134 commitDir <- (directory </>) <$> parseRelDir "commit" 135 blobDir <- (directory </>) <$> parseRelDir "blob" 136 treeDir <- (directory </>) <$> parseRelDir "tree" 137 ensureDir commitDir 138 ensureDir blobDir 139 ensureDir treeDir 140 141 -- Check which commits are new since the last run -- 142 newCommits <- getUpdates commitDir commits 143 144 -- Run the generator -- 145 let quiet = envQuiet env 146 force = envForce env 147 gen = genTarget scope runInIO quiet 148 149 mapM_ (generate scope runInIO quiet directory) (envRepoTemplates env) 150 151 whenJust (envCommitTemplate env) \commitT -> do 152 mapM_ (gen force commitT "commit" commitDir commitHref) newCommits 153 154 whenJust (envBlobTemplate env) \blobT -> do 155 let allBlobs = concatMap flattenFiles tree 156 if force 157 then mapM_ (gen True blobT "blob" blobDir blobHref) allBlobs 158 else 159 let updatedBlobs = getUpdatedFiles allBlobs newCommits 160 in mapM_ (gen True blobT "blob" blobDir blobHref) updatedBlobs 161 162 whenJust (envTreeTemplate env) \treeT -> do 163 -- A tree's own path never appears in a commit's diff (only 164 -- the blobs within it do), so unlike blobs, staleness can't 165 -- be judged by newCommits/getUpdatedFiles - always 166 -- regenerate every tree page. 167 let allTrees = concatMap flattenTrees tree 168 mapM_ (gen True treeT "tree" treeDir treeHref) allTrees 169 170 -- Copy any static files/folders into the output directory -- 171 envRepoCopyStatics env directory 172 173 return 174 repo{repositoryHead = Just headCommit} 175 176 {- 177 The role of the function above is to gather information about a git repository and 178 package it all together in such a way that various parts can be accessed and used by 179 Ginger templates. `package` takes any pre-loaded information and places it into a 180 hashmap for Ginger. Other non pre-loaded variables are looked up on the upon request. 181 -} 182 package :: 183 Env -> 184 [Repo] -> 185 Path Rel Dir -> 186 T.Text -> 187 [Commit] -> 188 [TreeEntry] -> 189 HashMap.HashMap T.Text (GVal RunRepo) 190 package env repos name description commits tree = 191 HashMap.fromList 192 [ ("host", toGVal . envHost $ env) 193 , ("repositories", toGVal repos) 194 , ("name", toGVal . T.pack . init . toFilePath $ name) 195 , ("description", toGVal description) 196 , ("commits", toGVal commits) 197 , ("tree", toGVal tree) 198 , ("entries", toGVal . concatMap flattenTree $ tree) 199 , ("blobs", toGVal . concatMap flattenFiles $ tree) 200 , ("trees", toGVal . concatMap flattenTrees $ tree) 201 , ("readme", toGVal . findFile "readme" $ tree) 202 , ("license", toGVal . findFile "license" $ tree) 203 ] 204 where 205 -- Find a file in the tree starting with the specified prefix. The prefix is looked 206 -- for on the full path, so will only find files in the top level directory. 207 findFile :: T.Text -> [TreeEntry] -> Maybe TreeEntry 208 findFile prefix = find (T.isPrefixOf prefix . T.toLower . treeEntryPath) 209 210 {- 211 Collect commit history up to a head. 212 -} 213 getCommits :: Git.CommitOid LgRepo -> ReaderT LgRepo IO [Commit] 214 getCommits commitID = 215 fmap reverse . sequence . mapMaybe loadCommit 216 <=< runConduit 217 $ Git.sourceObjects Nothing commitID False .| sinkList 218 where 219 loadCommit :: Git.ObjectOid LgRepo -> Maybe (ReaderT LgRepo IO Commit) 220 loadCommit (Git.CommitObjOid oid) = Just $ loadDiff =<< Git.lookupCommit oid 221 loadCommit _ = Nothing 222 223 {- 224 Collect diff information for a single commit. 225 -} 226 loadDiff :: Git.Commit LgRepo -> ReaderT LgRepo IO Commit 227 loadDiff gitCommit = do 228 newTree <- Git.lookupTree . Git.commitTree $ gitCommit 229 oldTree <- 230 case listToMaybe . Git.commitParents $ gitCommit of 231 Just parent -> 232 fmap Just . Git.lookupTree . Git.commitTree =<< Git.lookupCommit parent 233 Nothing -> 234 return Nothing 235 236 ioref <- liftIO . newIORef $ [] 237 lgDiffTreeToTree 238 (fileCallback ioref) 239 (hunkCallback ioref) 240 (dataCallback ioref) 241 oldTree 242 (Just newTree) 243 diffs <- liftIO . readIORef $ ioref 244 245 return . Commit gitCommit . fmap fixupLists $ diffs 246 where 247 fileCallback :: 248 IORef [Diff] -> 249 Ptr LG.C'git_diff_delta -> 250 CFloat -> 251 Ptr () -> 252 IO CInt 253 fileCallback ioref dPtr _progress _payload = do 254 delta <- peek dPtr 255 newFile <- B.packCString . LG.c'git_diff_file'path . LG.c'git_diff_delta'new_file $ delta 256 oldFile <- B.packCString . LG.c'git_diff_file'path . LG.c'git_diff_delta'old_file $ delta 257 let oldFile' = bool Nothing (Just oldFile) (newFile /= oldFile) 258 status = toEnum . fromIntegral . LG.c'git_diff_delta'status $ delta 259 diff = Diff newFile oldFile' status [] 260 modifyIORef ioref (diff :) 261 return 0 262 263 hunkCallback :: 264 IORef [Diff] -> 265 Ptr LG.C'git_diff_delta -> 266 Ptr LG.C'git_diff_range -> 267 CString -> 268 CSize -> 269 Ptr () -> 270 IO CInt 271 hunkCallback ioref _dPtr _range header headerLen _payload = do 272 (cur : _, rest) <- splitAt 1 <$> readIORef ioref 273 bs <- curry B.packCStringLen header (fromIntegral headerLen) 274 let hunk = Hunk bs [] 275 writeIORef ioref $ cur{diffHunks = hunk : diffHunks cur} : rest 276 return 0 277 278 dataCallback :: 279 IORef [Diff] -> 280 Ptr LG.C'git_diff_delta -> 281 Ptr LG.C'git_diff_range -> 282 CChar -> 283 CString -> 284 CSize -> 285 Ptr () -> 286 IO CInt 287 dataCallback ioref _dPtr _range lineOrigin content contentLen _payload = do 288 bs <- curry B.packCStringLen content (fromIntegral contentLen) 289 let bs' = B.cons (fromIntegral lineOrigin) bs 290 (cur : _, rest) <- splitAt 1 <$> readIORef ioref 291 let (curHunk : _, restHunks) = splitAt 1 . diffHunks $ cur 292 let updated = 293 cur 294 { diffHunks = 295 curHunk 296 { hunkLines = bs' : hunkLines curHunk 297 } : 298 restHunks 299 } 300 writeIORef ioref $ updated : rest 301 return 0 302 303 -- The callbacks prepend and then we put the lists the right way round here. 304 -- This avoids traversing the lists every time we add an item. 305 fixupLists :: Diff -> Diff 306 fixupLists diff = diff{diffHunks = fmap fixupLines . reverse . diffHunks $ diff} 307 where 308 fixupLines hunk = hunk{hunkLines = reverse . hunkLines $ hunk} 309 310 {- 311 Collect tree information for the given commit. Recurses on directories to list their 312 contents. 313 -} 314 getTree :: Git.CommitOid LgRepo -> ReaderT LgRepo IO [TreeEntry] 315 getTree = getTree' "" 0 . Git.commitTree <=< Git.lookupCommit 316 where 317 getTree' :: Git.TreeFilePath -> Int -> Git.TreeOid LgRepo -> ReaderT LgRepo IO [TreeEntry] 318 getTree' parent count toid = do 319 one <- Git.lookupTree toid 320 entries <- Git.listTreeEntries one 321 let entries' = fmap (prependParent parent) entries 322 contents <- mapM (\x -> getEntryContents x (count + 1)) entries' 323 modes <- mapM (getEntryModes . snd) entries' 324 return $ zipWith3 TreeEntry (fmap treePaths entries') contents modes 325 326 prependParent :: 327 Git.TreeFilePath -> 328 (Git.TreeFilePath, Git.TreeEntry r) -> 329 (Git.TreeFilePath, Git.TreeEntry r) 330 prependParent "" pathentry = pathentry 331 prependParent parent (path, entry) = (mconcat [parent, "/", path], entry) 332 333 getEntryContents :: (Git.TreeFilePath, Git.TreeEntry LgRepo) -> Int -> ReaderT LgRepo IO TreeEntryContents 334 getEntryContents (_, Git.BlobEntry oid _) _ = getBlobContents oid 335 getEntryContents (path, Git.TreeEntry oid) count = FolderContents <$> getTree' path count oid 336 getEntryContents (_, Git.CommitEntry oid) _ = return . FileContents . B.fromString . show . untag $ oid 337 338 getEntryModes :: Git.TreeEntry r -> ReaderT r IO TreeEntryMode 339 getEntryModes (Git.BlobEntry _ kind) = return . blobkindToMode $ kind 340 getEntryModes (Git.TreeEntry _) = return ModeDirectory 341 getEntryModes (Git.CommitEntry _) = return ModeSubmodule 342 343 treePaths :: (Git.TreeFilePath, Git.TreeEntry r) -> T.Text 344 treePaths = T.decodeUtf8With T.lenientDecode . fst 345 346 {- 347 Collect information about references. TODO: Find a more canonical way to split 348 references into tags or branches rather than filtering the refnames. 349 -} 350 getRefs :: T.Text -> ReaderT LgRepo IO [Ref] 351 getRefs ref = do 352 names <- filter (T.isPrefixOf ref) <$> Git.listReferences 353 maybeOids <- mapM Git.resolveReference names 354 let names' = catMaybes . zipWith dropName maybeOids $ names 355 objs <- mapM Git.lookupObject . catMaybes $ maybeOids 356 maybeCommits <- mapM refObjToCommit objs 357 let names'' = map (fromJust . T.stripPrefix ref) . catMaybes . zipWith dropName maybeCommits $ names' 358 return . zipWith Ref names'' . catMaybes $ maybeCommits 359 where 360 refObjToCommit :: 361 Git.Object LgRepo (ReaderT LgRepo IO) -> 362 ReaderT LgRepo IO (Maybe Commit) 363 refObjToCommit (Git.CommitObj obj) = Just <$> loadDiff obj 364 refObjToCommit _ = return Nothing 365 366 dropName :: Maybe a -> Git.RefName -> Maybe Git.RefName 367 dropName (Just _) name = Just name 368 dropName Nothing _ = Nothing 369 370 {- 371 Get the list of commits that need updating since the last run. New commits are 372 identified by the absence of their output file. 373 -} 374 getUpdates :: Path Abs Dir -> [Commit] -> IO [Commit] 375 getUpdates _ [] = return [] 376 getUpdates directory cs = go cs 377 where 378 dir = toFilePath directory 379 380 go :: [Commit] -> IO [Commit] 381 go [] = return [] 382 go (x : xs) = 383 ifM 384 (D.doesFileExist $ dir FP.</> commitHref x) 385 (return []) 386 ((x :) <$> go xs) 387 388 flattenFiles :: TreeEntry -> [TreeEntry] 389 flattenFiles treeentry = case treeEntryContents treeentry of 390 FolderContents files -> concatMap flattenFiles files 391 _ -> [treeentry] 392 393 flattenTrees :: TreeEntry -> [TreeEntry] 394 flattenTrees treeentry = case treeEntryContents treeentry of 395 FolderContents files -> treeentry : concatMap flattenTrees files 396 _ -> [] 397 398 getUpdatedFiles :: [TreeEntry] -> [Commit] -> [TreeEntry] 399 getUpdatedFiles [] _ = [] 400 getUpdatedFiles _ [] = [] 401 getUpdatedFiles files commits = filter ((`elem` updated) . treeEntryPath) files 402 where 403 updated :: [T.Text] 404 updated = fmap (bsToText . diffNewFile) . concatMap commitDiffs $ commits 405 406 {- 407 Render repository data into a template and save it to file. 408 -} 409 generate :: 410 HashMap.HashMap T.Text (GVal RunRepo) -> 411 (ReaderT LgRepo IO (GVal RunRepo) -> IO (GVal RunRepo)) -> 412 Bool -> 413 Path Abs Dir -> 414 Template -> 415 IO () 416 generate scope runInIO quiet directory template = do 417 let output = toFilePath (directory </> templatePath template) 418 unless quiet . putStrLn $ "Writing " <> output 419 TL.writeFile output =<< render (cbRepoLookup scope runInIO) template 420 421 {- 422 A Target refers to a template scope and repository object whose information is available 423 in that scope. For example, commits are a target as they each generate a scope 424 containing that commit's information, and these scopes are each rendered in the 425 commitTemplate. 426 -} 427 genTarget :: 428 ToGVal RunRepo t => 429 HashMap.HashMap T.Text (GVal RunRepo) -> 430 (ReaderT LgRepo IO (GVal RunRepo) -> IO (GVal RunRepo)) -> 431 Bool -> 432 Bool -> 433 Template -> 434 T.Text -> 435 Path Abs Dir -> 436 (t -> FilePath) -> 437 t -> 438 IO () 439 genTarget scope runInIO quiet force template category directory href target = do 440 output <- fmap (directory </>) . parseRelFile . href $ target 441 exists <- doesFileExist output 442 when (force || not exists) $ do 443 let output' = toFilePath output 444 scope' = HashMap.insert category (toGVal target) scope 445 unless quiet . putStrLn $ "Writing " <> output' 446 TL.writeFile output' =<< render (cbRepoLookup scope' runInIO) template 447 448 commitHref :: Commit -> FilePath 449 commitHref = (++ ".html") . commitHash 450 451 blobHref :: TreeEntry -> FilePath 452 blobHref = T.unpack . treePathToHref 453 454 treeHref :: TreeEntry -> FilePath 455 treeHref = T.unpack . treePathToHref 456 457 {- 458 With a dictionary of preloaded values and a function to access additional data, create a 459 lookup function for rendering. 460 -} 461 cbRepoLookup :: 462 HashMap.HashMap T.Text (GVal RunRepo) -> 463 (ReaderT LgRepo IO (GVal RunRepo) -> IO (GVal RunRepo)) -> 464 T.Text -> 465 RunRepo (GVal RunRepo) 466 cbRepoLookup scope runInIO key = liftIO . runInIO $ case key of 467 "tags" -> toGVal <$> getRefs "refs/tags/" 468 "branches" -> toGVal <$> getRefs "refs/heads/" 469 key' -> return . toGVal . HashMap.lookup key' $ scope 470