From 60e1de61a2b25b884adca946ff823a53e73852cd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 10 Apr 2014 13:48:01 +0300 Subject: [PATCH] Working! --- Application.hs | 4 +++- Handler/Home.hs | 11 +++++++++++ Handler/StackageHome.hs | 13 +++++++++++++ Handler/StackageIndex.hs | 13 +++++++++++++ Handler/{HackageSdist.hs => StackageSdist.hs} | 14 +++++++++----- Handler/UploadStackage.hs | 3 ++- Types.hs | 13 +++++++++++++ config/routes | 4 +++- stackage-server.cabal | 5 ++++- templates/homepage.hamlet | 7 ++++++- templates/stackage-home.hamlet | 8 ++++++++ 11 files changed, 85 insertions(+), 10 deletions(-) create mode 100644 Handler/StackageHome.hs create mode 100644 Handler/StackageIndex.hs rename Handler/{HackageSdist.hs => StackageSdist.hs} (50%) create mode 100644 templates/stackage-home.hamlet diff --git a/Application.hs b/Application.hs index ee7807e..e2cc277 100644 --- a/Application.hs +++ b/Application.hs @@ -33,8 +33,10 @@ import Handler.Home import Handler.Profile import Handler.Email import Handler.ResetToken -import Handler.HackageSdist import Handler.UploadStackage +import Handler.StackageHome +import Handler.StackageIndex +import Handler.StackageSdist -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the diff --git a/Handler/Home.hs b/Handler/Home.hs index 9e6a998..08bd4f4 100644 --- a/Handler/Home.hs +++ b/Handler/Home.hs @@ -2,6 +2,7 @@ module Handler.Home where import Import +import qualified Database.Esqueleto as E -- This is a handler function for the GET request method on the HomeR -- resource pattern. All of your resource patterns are defined in @@ -12,6 +13,16 @@ import Import -- inclined, or create a single monolithic file. getHomeR :: Handler Html getHomeR = do + stackages <- runDB $ E.select $ E.from $ \(stackage `E.InnerJoin` user) -> do + E.on (stackage E.^. StackageUser E.==. user E.^. UserId) + E.orderBy [E.desc $ stackage E.^. StackageUploaded] + return + ( stackage E.^. StackageIdent + , stackage E.^. StackageTitle + , stackage E.^. StackageUploaded + , user E.^. UserDisplay + , user E.^. UserHandle + ) defaultLayout $ do setTitle "Stackage Server" $(widgetFile "homepage") diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs new file mode 100644 index 0000000..fde0d03 --- /dev/null +++ b/Handler/StackageHome.hs @@ -0,0 +1,13 @@ +module Handler.StackageHome where + +import Import + +getStackageHomeR :: PackageSetIdent -> Handler Html +getStackageHomeR ident = do + (stackage, user) <- runDB $ do + Entity _ stackage <- getBy404 $ UniqueStackage ident + user <- get404 $ stackageUser stackage + return (stackage, user) + defaultLayout $ do + setTitle $ toHtml $ stackageTitle stackage + $(widgetFile "stackage-home") diff --git a/Handler/StackageIndex.hs b/Handler/StackageIndex.hs new file mode 100644 index 0000000..02a4a6c --- /dev/null +++ b/Handler/StackageIndex.hs @@ -0,0 +1,13 @@ +module Handler.StackageIndex where + +import Import +import Data.BlobStore + +getStackageIndexR :: PackageSetIdent -> Handler TypedContent +getStackageIndexR ident = do + msrc <- storeRead $ CabalIndex ident + case msrc of + Nothing -> notFound + Just src -> do + addHeader "content-disposition" "attachment; filename=\"00-index.tar.gz\"" + respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src diff --git a/Handler/HackageSdist.hs b/Handler/StackageSdist.hs similarity index 50% rename from Handler/HackageSdist.hs rename to Handler/StackageSdist.hs index d20da2f..5fb94ca 100644 --- a/Handler/HackageSdist.hs +++ b/Handler/StackageSdist.hs @@ -1,11 +1,15 @@ -module Handler.HackageSdist where +module Handler.StackageSdist where import Import -import Data.Hackage +import Data.BlobStore -getHackageSdistR :: PackageName -> Version -> Handler TypedContent -getHackageSdistR name version = do - msrc <- sourceHackageSdist name version +getStackageSdistR :: PackageSetIdent -> PackageNameVersion -> Handler TypedContent +getStackageSdistR ident (PackageNameVersion name version) = do + msrc1 <- storeRead (CustomSdist ident name version) + msrc <- + case msrc1 of + Just src -> return $ Just src + Nothing -> storeRead $ HackageSdist name version case msrc of Nothing -> notFound Just src -> do diff --git a/Handler/UploadStackage.hs b/Handler/UploadStackage.hs index 82757b7..0256af3 100644 --- a/Handler/UploadStackage.hs +++ b/Handler/UploadStackage.hs @@ -66,7 +66,8 @@ putUploadStackageR = do let indexLBS = GZip.compress $ Tar.write entries sourceLazy indexLBS $$ storeWrite (CabalIndex ident) runDB $ insert stackage - sendResponseCreated HomeR -- FIXME $ StackageR ident + setMessage "Stackage created" + redirect $ StackageHomeR ident where loop Tar.Done = return () loop (Tar.Fail e) = throwM e diff --git a/Types.hs b/Types.hs index 09b5294..3694a7e 100644 --- a/Types.hs +++ b/Types.hs @@ -4,6 +4,7 @@ import ClassyPrelude.Yesod import Data.BlobStore (ToPath (..)) import Text.Blaze (ToMarkup) import Database.Persist.Sql (PersistFieldSql) +import qualified Data.Text as T newtype PackageName = PackageName { unPackageName :: Text } deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup) @@ -12,6 +13,18 @@ newtype Version = Version { unVersion :: Text } newtype PackageSetIdent = PackageSetIdent { unPackageSetIdent :: Text } deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, PersistFieldSql) +data PackageNameVersion = PackageNameVersion !PackageName !Version + deriving (Show, Read, Typeable, Eq, Ord) + +instance PathPiece PackageNameVersion where + toPathPiece (PackageNameVersion x y) = concat [toPathPiece x, "-", toPathPiece y] + fromPathPiece t' | Just t <- stripSuffix ".tar.gz" t' = + case T.breakOnEnd "-" t of + ("", _) -> Nothing + (_, "") -> Nothing + (T.init -> name, version) -> Just $ PackageNameVersion (PackageName name) (Version version) + fromPathPiece _ = Nothing + data StoreKey = HackageCabal !PackageName !Version | HackageSdist !PackageName !Version | CabalIndex !PackageSetIdent diff --git a/config/routes b/config/routes index 899e216..ec762d5 100644 --- a/config/routes +++ b/config/routes @@ -8,5 +8,7 @@ /profile ProfileR GET PUT /email/#EmailId EmailR DELETE /reset-token ResetTokenR POST -/hackage/#PackageName/#Version HackageSdistR GET /upload UploadStackageR GET PUT +/stackage/#PackageSetIdent StackageHomeR GET +/stackage/#PackageSetIdent/00-index.tar.gz StackageIndexR GET +/stackage/#PackageSetIdent/package/#PackageNameVersion StackageSdistR GET diff --git a/stackage-server.cabal b/stackage-server.cabal index bc349a8..eab3934 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -27,8 +27,10 @@ library Handler.Profile Handler.Email Handler.ResetToken - Handler.HackageSdist Handler.UploadStackage + Handler.StackageHome + Handler.StackageIndex + Handler.StackageSdist if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT @@ -101,6 +103,7 @@ library , cryptohash , base64-bytestring , zlib + , esqueleto executable stackage-server if flag(library-only) diff --git a/templates/homepage.hamlet b/templates/homepage.hamlet index 4dd9420..6333996 100644 --- a/templates/homepage.hamlet +++ b/templates/homepage.hamlet @@ -1,6 +1,11 @@

Browse stackages -FIXME! +