mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-12 04:08:29 +01:00
112 lines
4.1 KiB
Haskell
112 lines
4.1 KiB
Haskell
module Handler.Haddock
|
|
( getHaddockR
|
|
, getHaddockBackupR
|
|
) where
|
|
|
|
import Import
|
|
import Stackage.Database
|
|
|
|
makeURL :: SnapName -> [Text] -> Text
|
|
makeURL slug rest = concat
|
|
$ "https://s3.amazonaws.com/haddock.stackage.org/"
|
|
: toPathPiece slug
|
|
: map (cons '/') rest
|
|
|
|
shouldRedirect :: Bool
|
|
shouldRedirect = False
|
|
|
|
getHaddockR :: SnapName -> [Text] -> Handler TypedContent
|
|
getHaddockR slug rest
|
|
| shouldRedirect = do
|
|
result <- redirectWithVersion slug rest
|
|
case result of
|
|
Just route -> redirect route
|
|
Nothing -> redirect $ makeURL slug rest
|
|
| final:_ <- reverse rest, ".html" `isSuffixOf` final = do
|
|
render <- getUrlRender
|
|
result <- redirectWithVersion slug rest
|
|
case result of
|
|
Just route -> redirect route
|
|
Nothing -> do
|
|
let extra = concat
|
|
[ "<link rel='stylesheet' href='https://fonts.googleapis.com/css?family=Open+Sans'>"
|
|
, "<link rel='stylesheet' href='"
|
|
, render $ StaticR haddock_style_css
|
|
, "'>"
|
|
]
|
|
req <- parseRequest $ unpack $ makeURL slug rest
|
|
(_, res) <- acquireResponse req >>= allocateAcquire
|
|
mstyle <- lookupGetParam "style"
|
|
case mstyle of
|
|
Just "plain" -> respondSource "text/html; charset=utf-8"
|
|
$ responseBody res .| mapC (Chunk . toBuilder)
|
|
_ -> respondSource "text/html; charset=utf-8" $ responseBody res .| (do
|
|
takeUntilChunk "</head>"
|
|
peekC >>= maybe (return ()) (const $ yield $ encodeUtf8 extra)
|
|
mapC id) .| mapC (Chunk . toBuilder)
|
|
| otherwise = redirect $ makeURL slug rest
|
|
|
|
takeUntilChunk :: Monad m => ByteString -> ConduitM ByteString ByteString m ()
|
|
takeUntilChunk fullNeedle =
|
|
start
|
|
where
|
|
start = await >>= mapM_ start'
|
|
|
|
start' bs =
|
|
case checkNeedle fullNeedle bs of
|
|
CNNotFound -> yield bs >> start
|
|
CNFound before after -> yield before >> leftover after
|
|
CNPartial before after newNeedle -> yield before >> loop (after:) newNeedle
|
|
|
|
loop front needle =
|
|
await >>= mapM_ loop'
|
|
where
|
|
loop' bs =
|
|
if needle `isPrefixOf` bs
|
|
then leftover $ concat $ front [bs]
|
|
else
|
|
case stripPrefix bs needle of
|
|
Just needle' -> loop (front . (bs:)) needle'
|
|
Nothing -> yieldMany (front [bs]) >> start
|
|
|
|
data CheckNeedle = CNNotFound | CNFound !ByteString !ByteString | CNPartial !ByteString !ByteString !ByteString
|
|
|
|
checkNeedle :: ByteString -> ByteString -> CheckNeedle
|
|
checkNeedle needle bs0 =
|
|
loop 0
|
|
where
|
|
loop idx
|
|
| idx >= length bs0 = CNNotFound
|
|
| otherwise =
|
|
case uncurry checkIndex $ splitAt idx bs0 of
|
|
CNNotFound -> loop (idx + 1)
|
|
res -> res
|
|
|
|
checkIndex before bs
|
|
| needle `isPrefixOf` bs = CNFound before bs
|
|
| Just needle' <- stripPrefix bs needle = CNPartial before bs needle'
|
|
| otherwise = CNNotFound
|
|
|
|
redirectWithVersion
|
|
:: (GetStackageDatabase m,MonadHandler m,RedirectUrl (HandlerSite m) (Route App))
|
|
=> SnapName -> [Text] -> m (Maybe (Route App))
|
|
redirectWithVersion slug rest =
|
|
case rest of
|
|
[pkg,file] -> do
|
|
Entity sid _ <- lookupSnapshot slug >>= maybe notFound return
|
|
mversion <- getPackageVersionBySnapshot sid pkg
|
|
case mversion of
|
|
Nothing -> return Nothing -- error "That package is not part of this snapshot."
|
|
Just version -> do
|
|
return (Just (HaddockR slug [pkg <> "-" <> version, file]))
|
|
_ -> return Nothing
|
|
|
|
getHaddockBackupR :: [Text] -> Handler ()
|
|
getHaddockBackupR (snap':rest)
|
|
| Just branch <- fromPathPiece snap' = track "Handler.Haddock.getHaddockBackupR" $ do
|
|
snapName <- newestSnapshot branch >>= maybe notFound pure
|
|
redirect $ HaddockR snapName rest
|
|
getHaddockBackupR rest = track "Handler.Haddock.getHaddockBackupR" $ redirect $ concat
|
|
$ "https://s3.amazonaws.com/haddock.stackage.org"
|
|
: map (cons '/') rest
|