{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} import Yesod.Core import Yesod.Form 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 qualified Data.HashMap.Strict as HMap 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.Yaml hiding (array) import Control.Monad (join, unless) import System.Console.CmdArgs import Network.Wai import Network.Wai.Handler.Warp (runSettings, defaultSettings, setPort, setHost) import Network.HTTP.Types (status403) import qualified Data.Text as T import Text.Blaze.Html (toHtml) import qualified Data.Vector as Vector import Data.Conduit (($$)) import Data.Conduit.List (consume) 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 -> Route Yackage tarballR pn v = TarballR $ tarballName pn v tarballName pn v = concat [ T.unpack $ toPathPiece pn , "-" , T.unpack $ toPathPiece v , ".tar.gz" ] cabalName pn v = concat [ T.unpack $ toPathPiece pn , "-" , T.unpack $ toPathPiece v , ".cabal" ] tarballPath pn v = do rd <- rootDir `fmap` getYesod return $ concat [ rd , '/' : T.unpack (toPathPiece pn) , '/' : T.unpack (toPathPiece v) ] instance Yesod Yackage instance PathPiece Version where fromPathPiece s = case filter (\(_, y) -> null y) $ readP_to_S parseVersion $ T.unpack s of [] -> Nothing (x, ""):_ -> Just x toPathPiece = T.pack . showVersion instance PathPiece PackageName where fromPathPiece = Just . PackageName . T.unpack toPathPiece = T.pack . unPackageName' getRootR :: Handler RepHtml getRootR = do y <- getYesod ps <- getYesod >>= liftIO . readMVar . packages >>= return . Map.toList defaultLayout $ do setTitle $ toHtml $ ytitle y toWidget [hamlet|