diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.3.0 + +* Support yesod-core 1.6 + ## 0.2.1.0 * Add back some missing changes from 0.1.1.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,9 @@ yesod-gitrepo ============= +[![Build Status](https://travis-ci.org/snoyberg/yesod-gitrepo.svg?branch=master)](https://travis-ci.org/snoyberg/yesod-gitrepo) +[![Build status](https://ci.appveyor.com/api/projects/status/l7vapfikbowucr2x/branch/master?svg=true)](https://ci.appveyor.com/project/snoyberg/yesod-gitrepo/branch/master) + yesod-gitrepo provides a means of embedding content from a Git repository inside a Yesod application. The typical workflow is: diff --git a/Yesod/GitRepo.hs b/Yesod/GitRepo.hs deleted file mode 100644 --- a/Yesod/GitRepo.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -module Yesod.GitRepo - ( GitRepo - , grRefresh - , grContent - , gitRepo - , gitRepoDev - , Route (..) - ) where - -import Control.Applicative ((<$>)) -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar) -import Control.Exception (mask_) -import Control.Exception.Enclosed (tryAny) -import Control.Monad (forever, void) -import Data.Foldable (fold) -import Data.IORef (newIORef, readIORef, writeIORef) -import Data.Monoid ((<>)) -import Data.Text (Text, pack, unpack) -import Network.HTTP.Types (status200) -import Network.Wai (responseLBS) -import Prelude (Eq, IO, Maybe (..), Monad (..), - Read, Show, error, error, map, - show, ($), FilePath) -import System.Directory (getTemporaryDirectory, - removeDirectory) -import System.Exit (ExitCode (ExitSuccess, ExitFailure)) -import System.IO.Temp (createTempDirectory) -import System.Process (createProcess, cwd, proc, - waitForProcess) -import Yesod.Core (ParseRoute (..), RenderRoute (..), - YesodSubDispatch (..), typePlain) -import Yesod.Core.Types (HandlerT, yreSite, ysreGetSub, - ysreParentEnv) - --- | A combination of Yesod subsite to be used for creating a refresh route, as --- well as action to extract the current value of the content and force a --- refresh. --- --- Since 0.1.0 -data GitRepo a = GitRepo - { grRefresh :: IO () - -- ^ Force a refresh of the content. Usually this is done automatically via - -- a POST request to the subsite route. - -- - -- Since 0.1.0 - , grContent :: IO a - -- ^ Get the current value of the content. - -- - -- Since 0.1.0 - } - --- | Create a new @GitRepo@ value that can be used as a refresh subsite, as --- well as to extract the current value of the content. --- --- Note that if the initial clone or user action fails, this function will --- throw an exception. For subsequent refreshes, the exception will be stored --- as an impure exception for future @grContent@ calls. --- --- Since 0.1.0 -gitRepo :: Text -- ^ URL - -> Text -- ^ branch name - -> (FilePath -> IO a) -- ^ what to do on clone/refresh - -> IO (GitRepo a) -gitRepo url branch refresh = do - tmpDir <- getTemporaryDirectory - contentDir <- createTempDirectory tmpDir "git-repo" - removeDirectory contentDir - git Nothing ["clone", "-b", branch, url, pack contentDir] - ref <- refresh contentDir >>= newIORef - var <- newEmptyMVar - mask_ $ void $ forkIO $ forever $ do - takeMVar var - void $ tryAny $ do - git (Just contentDir) ["fetch"] - git (Just contentDir) ["reset", "--hard", "origin/" <> branch] - refresh contentDir >>= writeIORef ref - - return GitRepo - { grRefresh = void $ tryPutMVar var () - , grContent = readIORef ref - } - -instance RenderRoute (GitRepo a) where - data Route (GitRepo a) = GitRepoRoute - deriving (Show, Eq, Read) - renderRoute _ = ([], []) - -instance ParseRoute (GitRepo a) where - parseRoute ([], []) = Just GitRepoRoute - parseRoute _ = Nothing - --- | Like 'gitRepo', but intended to be used in a dev environment. It just uses --- a hard-coded @FilePath@ and reloads the contents on each request. --- --- Since 0.1.1 -gitRepoDev :: FilePath - -> (FilePath -> IO a) - -> IO (GitRepo a) -gitRepoDev fp refresh = return GitRepo - { grRefresh = return () - , grContent = refresh fp - } - -instance YesodSubDispatch (GitRepo a) (HandlerT site IO) where - yesodSubDispatch env _req send = do - void $ forkIO $ grRefresh gr - send $ responseLBS status200 [("Content-Type", typePlain)] - "Reload initiated" - where - gr = ysreGetSub env $ yreSite $ ysreParentEnv env - -git :: Maybe FilePath -> [Text] -> IO () -git mdir args = do - (Nothing, Nothing, Nothing, ph) <- createProcess - (proc "git" $ map unpack args) - { cwd = mdir - } - ec <- waitForProcess ph - case ec of - ExitSuccess -> return () - ExitFailure i -> error $ fold - [ "Ran git in dir " - , show mdir - , " with args " - , show args - , " failed with exit code " - , show i - ] diff --git a/src/Yesod/GitRepo.hs b/src/Yesod/GitRepo.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/GitRepo.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +module Yesod.GitRepo + ( GitRepo + , grRefresh + , grContent + , gitRepo + , gitRepoDev + , Route (..) + ) where + +import Control.Applicative ((<$>)) +import Control.Concurrent (forkIO) +import Control.Monad (forever, void) +import Data.Foldable (fold) +import Data.Monoid ((<>)) +import Data.Text (Text, pack, unpack) +import Network.HTTP.Types (status200) +import Network.Wai (responseLBS) +import Prelude (Eq, IO, Maybe (..), Monad (..), + Read, Show, error, error, map, + show, ($), FilePath) +import System.Directory (getTemporaryDirectory, + removeDirectory) +import System.Exit (ExitCode (ExitSuccess, ExitFailure)) +import UnliftIO +import qualified System.IO.Temp +import System.Process (createProcess, cwd, proc, + waitForProcess) +import Yesod.Core (ParseRoute (..), RenderRoute (..), + YesodSubDispatch (..), typePlain, + HandlerFor) +import Yesod.Core.Types (yreSite, ysreGetSub, + ysreParentEnv) + +-- | A combination of Yesod subsite to be used for creating a refresh route, as +-- well as action to extract the current value of the content and force a +-- refresh. +-- +-- Since 0.1.0 +data GitRepo a = GitRepo + { grRefresh :: IO () + -- ^ Force a refresh of the content. Usually this is done automatically via + -- a POST request to the subsite route. + -- + -- Since 0.1.0 + , grContent :: IO a + -- ^ Get the current value of the content. + -- + -- Since 0.1.0 + } + +-- | Create a new @GitRepo@ value that can be used as a refresh subsite, as +-- well as to extract the current value of the content. +-- +-- Note that if the initial clone or user action fails, this function will +-- throw an exception. For subsequent refreshes, the exception will be stored +-- as an impure exception for future @grContent@ calls. +-- +-- Since 0.1.0 +gitRepo :: Text -- ^ URL + -> Text -- ^ branch name + -> (FilePath -> IO a) -- ^ what to do on clone/refresh + -> IO (GitRepo a) +gitRepo url branch refresh = do + tmpDir <- getTemporaryDirectory + contentDir <- System.IO.Temp.createTempDirectory tmpDir "git-repo" + removeDirectory contentDir + git Nothing ["clone", "-b", branch, url, pack contentDir] + ref <- refresh contentDir >>= newIORef + var <- newEmptyMVar + mask_ $ void $ forkIO $ forever $ do + takeMVar var + void $ tryAny $ do + git (Just contentDir) ["fetch"] + git (Just contentDir) ["reset", "--hard", "origin/" <> branch] + refresh contentDir >>= writeIORef ref + + return GitRepo + { grRefresh = void $ tryPutMVar var () + , grContent = readIORef ref + } + +instance RenderRoute (GitRepo a) where + data Route (GitRepo a) = GitRepoRoute + deriving (Show, Eq, Read) + renderRoute _ = ([], []) + +instance ParseRoute (GitRepo a) where + parseRoute ([], []) = Just GitRepoRoute + parseRoute _ = Nothing + +-- | Like 'gitRepo', but intended to be used in a dev environment. It just uses +-- a hard-coded @FilePath@ and reloads the contents on each request. +-- +-- Since 0.1.1 +gitRepoDev :: FilePath + -> (FilePath -> IO a) + -> IO (GitRepo a) +gitRepoDev fp refresh = return GitRepo + { grRefresh = return () + , grContent = refresh fp + } + +instance YesodSubDispatch (GitRepo a) site where + yesodSubDispatch env _req send = do + void $ forkIO $ grRefresh gr + send $ responseLBS status200 [("Content-Type", typePlain)] + "Reload initiated" + where + gr = ysreGetSub env $ yreSite $ ysreParentEnv env + +git :: Maybe FilePath -> [Text] -> IO () +git mdir args = do + (Nothing, Nothing, Nothing, ph) <- createProcess + (proc "git" $ map unpack args) + { cwd = mdir + } + ec <- waitForProcess ph + case ec of + ExitSuccess -> return () + ExitFailure i -> error $ fold + [ "Ran git in dir " + , show mdir + , " with args " + , show args + , " failed with exit code " + , show i + ] diff --git a/yesod-gitrepo.cabal b/yesod-gitrepo.cabal --- a/yesod-gitrepo.cabal +++ b/yesod-gitrepo.cabal @@ -1,28 +1,46 @@ -name: yesod-gitrepo -version: 0.2.1.0 -synopsis: Host content provided by a Git repo -description: See README.md -homepage: https://github.com/snoyberg/yesod-gitrepo -license: MIT -license-file: LICENSE -author: Michael Snoyman -maintainer: michael@snoyman.com -category: Web -build-type: Simple -extra-source-files: README.md - ChangeLog.md -cabal-version: >=1.10 +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 71987855e877993e60d8044cd8a7a476541cdc9f3dd5ecfa900311d0fd5dcd01 +name: yesod-gitrepo +version: 0.3.0 +synopsis: Host content provided by a Git repo +description: Please see the README and generated docs at +category: Web +homepage: https://github.com/snoyberg/yesod-gitrepo#readme +bug-reports: https://github.com/snoyberg/yesod-gitrepo/issues +author: Michael Snoyman +maintainer: michael@snoyman.com +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/snoyberg/yesod-gitrepo + library - exposed-modules: Yesod.GitRepo - build-depends: base < 5 - , temporary >=1.2 - , directory - , yesod-core >=1.2 && <1.5 - , wai >=3.0 - , http-types - , process >=1.1 - , lifted-base - , text - , enclosed-exceptions - default-language: Haskell2010 + hs-source-dirs: + src + build-depends: + base >=4.9 && <10 + , directory + , http-types + , process >=1.1 + , temporary + , text + , unliftio + , wai >=3.0 + , yesod-core >=1.6 && <1.7 + exposed-modules: + Yesod.GitRepo + other-modules: + Paths_yesod_gitrepo + default-language: Haskell2010