{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} import Yesod.Core import Yesod.Dispatch import Yesod.Handler import Yesod.Widget import Yesod.Content import Yesod.Form import Yesod.Request import Text.Hamlet import Control.Monad.IO.Class (liftIO) import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Parse import Distribution.Version import Data.Version import qualified Data.Map as Map import Data.Map (Map) import Text.ParserCombinators.ReadP hiding (string) import System.Directory import System.Environment import Data.Set (Set, toAscList) import qualified Data.Set as Set import Control.Concurrent.MVar import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import Codec.Archive.Tar (Entries (..), entryPath, entryContent, EntryContent (NormalFile)) import Codec.Compression.GZip (decompress, compress) import Data.Text.Lazy (unpack) import Data.Text.Lazy.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import qualified Data.ByteString.Lazy as L import Data.Maybe (fromMaybe) import Data.Object import Data.Object.Yaml import Control.Monad (join, unless) import System.Console.CmdArgs import Network.Wai import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort, settingsHost) import Network.HTTP.Types (status403) import qualified Data.Text as T import Text.Blaze (toHtml) data Args = Args { port :: Int , password :: Maybe String , localhost :: Bool , rootdir :: Maybe String , title :: String } deriving (Show, Data, Typeable) type CabalFile = FilePath type Tarball = FilePath data Yackage = Yackage { rootDir :: FilePath , packages :: MVar PackageDB , ypassword :: Maybe String , ytitle :: String } type PackageDB = Map PackageName (Set Version) mkYesod "Yackage" [$parseRoutes| / RootR GET POST /00-index.tar.gz IndexR GET /package/#String TarballR GET |] tarballR :: PackageName -> Version -> YackageRoute tarballR pn v = TarballR $ tarballName pn v tarballName pn v = concat [ T.unpack $ toSinglePiece pn , "-" , T.unpack $ toSinglePiece v , ".tar.gz" ] cabalName pn v = concat [ T.unpack $ toSinglePiece pn , "-" , T.unpack $ toSinglePiece v , ".cabal" ] tarballPath pn v = do rd <- rootDir `fmap` getYesod return $ concat [ rd , '/' : T.unpack (toSinglePiece pn) , '/' : T.unpack (toSinglePiece v) ] instance Yesod Yackage where approot _ = "" instance SinglePiece Version where fromSinglePiece s = case filter (\(_, y) -> null y) $ readP_to_S parseVersion $ T.unpack s of [] -> Nothing (x, ""):_ -> Just x toSinglePiece = T.pack . showVersion instance SinglePiece PackageName where fromSinglePiece = Just . PackageName . T.unpack toSinglePiece = T.pack . unPackageName getRootR :: Handler RepHtml getRootR = do y <- getYesod ps <- getYesod >>= liftIO . readMVar . packages >>= return . Map.toList defaultLayout $ do setTitle $ toHtml $ ytitle y addHamlet [$hamlet|\