diff --git a/yackage-upload.hs b/yackage-upload.hs --- a/yackage-upload.hs +++ b/yackage-upload.hs @@ -14,7 +14,7 @@ [x, y] -> (x, "", y) [x, y, z] -> (x, y, z) _ -> error "Usage: yackage-upload [password] " - req <- parseUrl url + req <- parseUrl $ S8.pack url body <- mkBody pass file let req' = req { method = "POST" @@ -22,9 +22,9 @@ [ ("Content-Type", "multipart/form-data; boundary=" `S8.append` bound) , ("Content-Length", S8.pack $ show $ L.length body) ] - , requestBody = body + , requestBody = RequestBodyLBS body } - res <- httpLbs req' + res <- withManager $ httpLbs req' L.putStrLn $ responseBody res bound = "YACKAGEUPLOAD" diff --git a/yackage.cabal b/yackage.cabal --- a/yackage.cabal +++ b/yackage.cabal @@ -1,5 +1,5 @@ Name: yackage -Version: 0.0.1.2 +Version: 0.1.0 Synopsis: Personal Hackage replacement for testing new packages. Description: This package installs a yackage executable that runs a simplistic hackage-like server. It allows you to upload packages produced via cabal sdist and install them via cabal. The trick is to add the yackage repository to your cabal config file, with a line such as: @@ -18,7 +18,8 @@ Executable yackage Main-is: yackage.hs Build-depends: base >= 4 && < 5 - , yesod >= 0.6 && < 0.7 + , yesod-core >= 0.7 && < 0.8 + , warp , Cabal , bytestring , text @@ -30,12 +31,14 @@ , data-object-yaml , cmdargs , wai - , wai-extra + , transformers + , hamlet + , yesod-form Executable yackage-upload Main-is: yackage-upload.hs - Build-depends: http-enumerator >= 0.2 && < 0.3 - , blaze-builder >= 0.2.1.3 && < 0.3 + Build-depends: http-enumerator >= 0.5.1 && < 0.6 + , blaze-builder >= 0.2.1.3 && < 0.4 source-repository head type: git diff --git a/yackage.hs b/yackage.hs --- a/yackage.hs +++ b/yackage.hs @@ -1,7 +1,16 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} -import Yesod +{-# 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 @@ -9,7 +18,7 @@ import Data.Version import qualified Data.Map as Map import Data.Map (Map) -import Text.ParserCombinators.ReadP +import Text.ParserCombinators.ReadP hiding (string) import System.Directory import System.Environment import Data.Set (Set, toAscList) @@ -29,13 +38,14 @@ import Control.Monad (join, unless) import System.Console.CmdArgs import Network.Wai -import Network.Wai.Handler.SimpleServer (run) +import Network.Wai.Handler.Warp (run) data Args = Args { port :: Int , password :: Maybe String , localhost :: Bool , rootdir :: Maybe String + , title :: String } deriving (Show, Data, Typeable) type CabalFile = FilePath @@ -45,6 +55,7 @@ { rootDir :: FilePath , packages :: MVar PackageDB , ypassword :: Maybe String + , ytitle :: String } type PackageDB = Map PackageName (Set Version) @@ -98,26 +109,26 @@ y <- getYesod ps <- getYesod >>= liftIO . readMVar . packages >>= return . Map.toList defaultLayout $ do - setTitle "Yackage" - addHamlet [$hamlet| -%h1 Yackage -%form!method=post!enctype=multipart/form-data - %div - Upload a new file: $ - %input!type=file!name=file - $maybe ypassword.y _ - %div - Password: $ - %input!type=password!name=password - %div - %input!type=submit!value=Upload -%dl - $forall ps p - %dt $unPackageName.fst.p$ - %dd - $forall toAscList.snd.p v - %a!href=@(tarballR.fst.p).v@ $toSinglePiece.v$ - \ $ + setTitle $ string $ ytitle y + addHamlet [$hamlet|\ +

Yackage +
+
+ \Upload a new file: + + $maybe _ <- ypassword y +
+ \Password: + +
+ +
+ $forall p <- ps +
#{unPackageName (fst p)} +
+ $forall v <- toAscList (snd p) + #{toSinglePiece v} + \ |] postRootR = do @@ -127,8 +138,7 @@ Just p -> do p' <- runFormPost' $ maybeStringInput "password" unless (Just p == p') $ permissionDenied "Invalid password" - rr <- getRequest - (_, files) <- liftIO $ reqRequestBody rr + (_, files) <- runRequestBody content <- case lookup "file" files of Nothing -> error "No file upload found" @@ -187,6 +197,7 @@ , password = Nothing &= help "Optional password required to upload files" , localhost = False &= help "Only allow connections from localhost?" , rootdir = Nothing &= help "Root folder for Yackage config file and packages" + , title = "Yackage" &= help "Page title displayed in browser" } &= program progname &= summary "Run a Yackage server" path <- case rootdir args of @@ -199,16 +210,16 @@ then parseConfig `fmap` join (decodeFile config) else return $ Map.empty m' <- liftIO $ newMVar m - app <- toWaiApp $ Yackage path m' $ password args + app <- toWaiApp $ Yackage path m' (password args) (title args) let app' = if localhost args then onlyLocal app else app putStrLn $ "Running Yackage on port " ++ show (port args) ++ ", rootdir: " ++ path run (port args) app' onlyLocal app req = - if remoteHost req `elem` ["127.0.0.1", "::1", "localhost"] + if takeWhile (/= ':') (show $ remoteHost req) `elem` ["127.0.0.1", "localhost"] then app req - else return $ Response status403 [("Content-Type", "text/plain")] - $ ResponseLBS "This Yackage server only talks to local clients" + else return $ responseLBS status403 [("Content-Type", "text/plain")] + "This Yackage server only talks to local clients" unPackageName (PackageName s) = s