{-# LANGUAGE OverloadedStrings #-}moduleBlaaargh.Internal.Handlers(serveBlaaargh)whereimportControl.Monad.StateimportqualifiedData.ByteString.Char8asBimportqualifiedData.ByteString.Lazy.Char8asLimportData.ByteString.Char8(ByteString)importData.ListimportqualifiedData.MapasMapimportData.MaybeimportData.MonoidimportHappstack.ServerimportHappstack.Server.HTTP.FileServeimportHappstack.Server.PartsimportSystem.Log.LoggerimportqualifiedText.Atom.FeedasAtomimportText.PrintfimportText.StringTemplate------------------------------------------------------------------------------importBlaaargh.Internal.PostimportBlaaargh.Internal.TemplatesimportBlaaargh.Internal.TypesimportqualifiedBlaaargh.Internal.Util.ExcludeListasEL------------------------------------------------------------------------------debug::(MonadIOm)=>String->m()debug=liftIO.debugM"blaaargh"showPath::[ByteString]->StringshowPath=B.unpack.B.intercalate"/"------------------------------------------------------------------------------{-|
The top-level happstack handler. The 'BlaaarghHandler' is a 'ServerPartT' over
a state monad; you \"run\" this handler by feeding it a BlaaarghState using
'runBlaaarghHandler'. It handles requests on its base url (defined in the
@{blaaargh_dir}/config@ file) and serves up content from the content area.
-}serveBlaaargh::BlaaarghHandlerserveBlaaargh=domethodOnlyGETcompressedResponseFiltercm<-liftget>>=return.blaaarghPostMappaths<-askRq>>=return.mapB.pack.rqPathsserve[]pathscm`mappend`fourohfourwhere--------------------------------------------------------------------------serve::[ByteString]->[ByteString]->ContentMap->BlaaarghHandlerservesoFarpathscontent=dodebug$printf"serve: soFar=%s paths=%s"(showPathsoFar)(showPathpaths)casepathsof[]->serveIndexsoFarcontent(a:[])->serveFilesoFaracontent(a:b)->serveDirsoFarabcontent--------------------------------------------------------------------------serveFile::[ByteString]->ByteString->ContentMap->BlaaarghHandlerserveFilesoFaracontent=dodebug$printf"serveFile: soFar=%s a=%s"(showPathsoFar)(B.unpacka)ifa=="feed.xml"thenserveFeedsoFarcontentelsemaybe(dodebug$printf"serveFile: 404: soFar=%s a=%s"(showPathsoFar)(B.unpacka)mzero)(\f->casefof(ContentStaticfp)->serveStaticfp(ContentPostpost)->servePost(soFar++[a])post(ContentDirectory_d)->serveIndex(soFar++[a])d)(Map.lookupacontent)--------------------------------------------------------------------------serveDir::[ByteString]->ByteString->[ByteString]->ContentMap->BlaaarghHandlerserveDirsoFardrestcontent=doletmbD=Map.lookupdcontentdebug$printf"serveDir: 404: soFar=%s d=%s rest=%s"(showPathsoFar)(B.unpackd)(showPathrest)maybemzero(\f->casefof(ContentDirectory_mp)->serve(soFar++[d])restmp_->mzero)mbD------------------------------------------------------------------------------fourohfour::BlaaarghHandlerfourohfour=dostate<-liftgetmbTmpl<-findFourOhFourTemplatetmpl<-maybemzeroreturnmbTmpllettitle=getTextContent.Atom.feedTitle.blaaarghFeedInfo$statelettmpl'=setAttribute"pageTitle"titletmplreturn$toResponse$HtmlResponse$rendertmpl'------------------------------------------------------------------------------serveStatic::FilePath->BlaaarghHandlerserveStatic=localRq(\r->r{rqPaths=[]}).fileServeStrict[]newtypeHtmlResponse=HtmlResponseByteStringinstanceToMessageHtmlResponsewheretoContentType_="text/html"toMessage(HtmlResponses)=L.fromChunks[s]------------------------------------------------------------------------------servePost::[ByteString]->Post->BlaaarghHandlerservePostsoFarpost=dostate<-liftgetmbTmpl<-lift$findTemplateForPostsoFartmpl<-maybemzeroreturnmbTmpllettitle=concat[getTextContent.Atom.feedTitle.blaaarghFeedInfo$state,(lets=getTextContent.Atom.entryTitle.unPost$postinifnullsthen""else": "++s)]lettmpl'=setAttribute"post"post$setAttribute"pageTitle"titletmplreturn$toResponse$HtmlResponse$rendertmpl'------------------------------------------------------------------------------getTextContent::Atom.TextContent->StringgetTextContent(Atom.TextStrings)=sgetTextContent(Atom.HTMLStrings)=sgetTextContent_=undefined-- don't support that yet------------------------------------------------------------------------------getContentTitle::ContentItem->StringgetContentTitle(ContentPost(Postp))=getTextContent.Atom.entryTitle$pgetContentTitle_=""------------------------------------------------------------------------------serveIndex::[ByteString]->ContentMap->BlaaarghHandlerserveIndexsoFarcontent=dodebug$printf"serveIndex: soFar=%s"(showPathsoFar)state<-liftgetmbTmpl<-lift$findTemplateForDirectorysoFartmpl<-maybemzeroreturnmbTmplletexcludes'=blaaarghFeedExcludesstateletexcludes=foldl'(flipEL.descend)excludes'soFarletalpha=alphabeticalPostsexcludescontentletchron=chronologicalPostsexcludescontentletrchron=reverseChronologicalPostsexcludescontentletrecent=take5rchronletpostmap=[("alphabeticalPosts",alpha),("chronologicalPosts",chron),("reverseChronologicalPosts",rchron),("recentPosts",recent)]lettmpl'=setManyAttribpostmaptmplletmbPost=Map.lookup"index"contentletbaseURL=B.pack$blaaarghBaseURLstateletfdPath=B.concat$intersperse"/"$soFar++["feed.xml"]letfeedURL=B.unpack$B.concat[baseURL,"/",fdPath]lettitle=concat[getTextContent.Atom.feedTitle.blaaarghFeedInfo$state,maybe""(\x->lets=getContentTitlexinifnullsthen""else": "++s)mbPost]lettmpl''=casembPostof(Just(ContentPostp))->setAttribute"post"ptmpl'_->tmpl'letautoDiscovery'=printf"<link rel=\"alternate\" \
\type=\"application/atom+xml\" \
\href=\"%s\">"feedURL::StringletautoDiscovery=ifEL.matchListsoFarexcludesthen""elseautoDiscovery'lettmpl'''=setAttribute"pageTitle"title$setAttribute"extraHead"autoDiscoverytmpl''return$toResponse$HtmlResponse$rendertmpl'''------------------------------------------------------------------------------addSiteURL::String->Post->PostaddSiteURLsiteURL(Postp)=Post$p{Atom.entryId=concat[siteURL,Atom.entryIdp]}------------------------------------------------------------------------------serveFeed::[ByteString]->ContentMap->BlaaarghHandlerserveFeedsoFarcontent=dostate<-liftgetletexcludes'=blaaarghFeedExcludesstateletexcludes=foldl'(flipEL.descend)excludes'soFarletsiteURL'=blaaarghSiteURLstateletposts=map(addSiteURLsiteURL')$recentPostsexcludescontent5hasTemplate<-lift$liftMisJust$findTemplateForDirectorysoFarifnullposts||nothasTemplatethenmzeroelsedoletsiteURL=B.packsiteURL'letbaseURL=B.pack$blaaarghBaseURLstateletfdPath=B.concat$intersperse"/"$soFar++["feed.xml"]letfeedURL=B.unpack$B.concat$[siteURL,baseURL,"/",fdPath]letbaseFeed=blaaarghFeedInfostateletfeed=baseFeed{Atom.feedId=feedURL,Atom.feedLinks=[Atom.nullLinkfeedURL],Atom.feedEntries=mapunPostposts,Atom.feedUpdated=Atom.entryUpdated$unPost(headposts)}return$toResponsefeed