{-# LANGUAGE BangPatterns #-}{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE TupleSections #-}moduleSnap.Snaplet.Internal.Initializer(addPostInitHook,addPostInitHookBase,toSnapletHook,bracketInit,modifyCfg,nestSnaplet,embedSnaplet,makeSnaplet,nameSnaplet,onUnload,addRoutes,wrapSite,runInitializer,runSnaplet,combineConfig,serveSnaplet,loadAppConfig,printInfo,getRoutes,getEnvironment,modifyMaster)whereimportPreludehiding(catch)importControl.Concurrent.MVarimportControl.ErrorimportControl.Exception(SomeException)importControl.LensimportControl.MonadimportControl.Monad.CatchIOhiding(Handler)importControl.Monad.ReaderimportControl.Monad.StateimportControl.Monad.Trans.Writerhiding(pass)importData.ByteString.Char8(ByteString)importqualifiedData.ByteString.Char8asBimportData.ConfiguratorimportqualifiedData.Configurator.TypesasCimportData.IORefimportData.MaybeimportData.Text(Text)importqualifiedData.TextasTimportSnap.Http.ServerimportSnap.CoreimportSnap.Util.GZipimportSystem.DirectoryimportSystem.Directory.TreeimportSystem.FilePath.PosiximportSystem.IOimportSnap.Snaplet.ConfigimportqualifiedSnap.Snaplet.Internal.LensTasLTimportqualifiedSnap.Snaplet.Internal.LensedasLimportSnap.Snaplet.Internal.Types-------------------------------------------------------------------------------- | 'get' for InitializerState.iGet::Initializerbv(InitializerStateb)iGet=Initializer$LT.getBase-------------------------------------------------------------------------------- | 'modify' for InitializerState.iModify::(InitializerStateb->InitializerStateb)->Initializerbv()iModifyf=Initializer$dob<-LT.getBaseLT.putBase$fb-------------------------------------------------------------------------------- | 'gets' for InitializerState.iGets::(InitializerStateb->a)->InitializerbvaiGetsf=Initializer$dob<-LT.getBasereturn$fb-------------------------------------------------------------------------------- | Lets you retrieve the list of routes currently set up by an Initializer.-- This can be useful in debugging.getRoutes::Initializerbv[ByteString]getRoutes=liftM(mapfst)$iGets_handlers-------------------------------------------------------------------------------- | Return the current environment string. This will be the-- environment given to 'runSnaplet' or from the command line when-- using 'serveSnaplet'. Usefully for changing behavior during-- development and testing.getEnvironment::InitializerbvStringgetEnvironment=iGets_environment-------------------------------------------------------------------------------- | Converts a plain hook into a Snaplet hook.toSnapletHook::(v->EitherTTextIOv)->(Snapletv->EitherTTextIO(Snapletv))toSnapletHookf(Snapletcfgresetval)=doval'<-fvalreturn$!Snapletcfgresetval'-------------------------------------------------------------------------------- | Adds an IO action that modifies the current snaplet state to be run at-- the end of initialization on the state that was created. This makes it-- easier to allow one snaplet's state to be modified by another snaplet's-- initializer. A good example of this is when a snaplet has templates that-- define its views. The Heist snaplet provides the 'addTemplates' function-- which allows other snaplets to set up their own templates. 'addTemplates'-- is implemented using this function.addPostInitHook::(v->EitherTTextIOv)->Initializerbv()addPostInitHook=addPostInitHook'.toSnapletHookaddPostInitHook'::(Snapletv->EitherTTextIO(Snapletv))->Initializerbv()addPostInitHook'h=doh'<-upHookhaddPostInitHookBaseh'-------------------------------------------------------------------------------- | Variant of addPostInitHook for when you have things wrapped in a Snaplet.addPostInitHookBase::(Snapletb->EitherTTextIO(Snapletb))->Initializerbv()addPostInitHookBase=Initializer.lift.tell.Hook-------------------------------------------------------------------------------- | Helper function for transforming hooks.upHook::(Snapletv->EitherTTextIO(Snapletv))->Initializerbv(Snapletb->EitherTTextIO(Snapletb))upHookh=Initializer$dol<-askreturn$upHook'lh-------------------------------------------------------------------------------- | Helper function for transforming hooks.upHook'::Monadm=>ALens'ba->(a->ma)->b->mbupHook'lhb=dov<-h(b^#l)return$storinglvb-------------------------------------------------------------------------------- | Modifies the Initializer's SnapletConfig.modifyCfg::(SnapletConfig->SnapletConfig)->Initializerbv()modifyCfgf=iModify$overcurConfig$\c->fc-------------------------------------------------------------------------------- | If a snaplet has a filesystem presence, this function creates and copies-- the files if they dont' already exist.setupFilesystem::Maybe(IOFilePath)-- ^ The directory where the snaplet's reference files are-- stored. Nothing if the snaplet doesn't come with any-- files that need to be installed.->FilePath-- ^ Directory where the files should be copied.->Initializerbv()setupFilesystemNothing_=return()setupFilesystem(JustgetSnapletDataDir)targetDir=doexists<-liftIO$doesDirectoryExisttargetDirunlessexists$doprintInfo"...setting up filesystem"liftIO$createDirectoryIfMissingTruetargetDirsrcDir<-liftIOgetSnapletDataDirliftIO$readDirectoryWith(doCopysrcDirtargetDir)srcDirreturn()wheredoCopysrcRoottargetRootfilename=docreateDirectoryIfMissingTruedirectorycopyFilefilenametoDirwheretoDir=targetRoot</>makeRelativesrcRootfilenamedirectory=dropFileNametoDir-------------------------------------------------------------------------------- | All snaplet initializers must be wrapped in a call to @makeSnaplet@,-- which handles standardized housekeeping common to all snaplets.-- Common usage will look something like-- this:---- @-- fooInit :: SnapletInit b Foo-- fooInit = makeSnaplet \"foo\" \"An example snaplet\" Nothing $ do-- -- Your initializer code here-- return $ Foo 42-- @---- Note that you're writing your initializer code in the Initializer monad,-- and makeSnaplet converts it into an opaque SnapletInit type. This allows-- us to use the type system to ensure that the API is used correctly.makeSnaplet::Text-- ^ A default id for this snaplet. This is only used when-- the end-user has not already set an id using the-- nameSnaplet function.->Text-- ^ A human readable description of this snaplet.->Maybe(IOFilePath)-- ^ The path to the directory holding the snaplet's reference-- filesystem content. This will almost always be the-- directory returned by Cabal's getDataDir command, but it-- has to be passed in because it is defined in a-- package-specific import. Setting this value to Nothing-- doesn't preclude the snaplet from having files in in the-- filesystem, it just means that they won't be copied there-- automatically.->Initializerbvv-- ^ Snaplet initializer.->SnapletInitbvmakeSnapletsnapletIddescgetSnapletDataDirm=SnapletInit$domodifyCfg$\c->ifisNothing$_scIdcthensetscId(JustsnapletId)celsecsid<-iGets(T.unpack.fromJust._scId._curConfig)topLevel<-iGets_isTopLevelunlesstopLevel$domodifyCfg$overscUserConfig(subconfig(T.packsid))modifyCfg$\c->setscFilePath(_scFilePathc</>"snaplets"</>sid)ciModify(setisTopLevelFalse)modifyCfg$setscDescriptiondesccfg<-iGets_curConfigprintInfo$T.pack$concat["Initializing ",sid," @ /",B.unpack$buildPath$_scRouteContextcfg]-- This has to happen here because it needs to be after scFilePath is set-- up but before the config file is read.setupFilesystemgetSnapletDataDir(_scFilePathcfg)env<-iGets_environmentletconfigLocation=_scFilePathcfg</>(env++".cfg")liftIO$addToConfig[OptionalconfigLocation](_scUserConfigcfg)mkSnapletm-------------------------------------------------------------------------------- | Internal function that gets the SnapletConfig out of the initializer-- state and uses it to create a (Snaplet a).mkSnaplet::Initializerbvv->Initializerbv(Snapletv)mkSnapletm=dores<-mcfg<-iGets_curConfigsetInTop<-iGetsmasterReloaderl<-getLensletmodifier=setInTop.set(cloneLensl.snapletValue)return$Snapletcfgmodifierres-------------------------------------------------------------------------------- | Brackets an initializer computation, restoring curConfig after the-- computation returns.bracketInit::Initializerbva->InitializerbvabracketInitm=dos<-iGetres<-miModify(setcurConfig(_curConfigs))returnres-------------------------------------------------------------------------------- | Handles modifications to InitializerState that need to happen before a-- snaplet is called with either nestSnaplet or embedSnaplet.setupSnapletCall::ByteString->Initializerbv()setupSnapletCallrte=docurId<-iGets(fromJust._scId._curConfig)modifyCfg(overscAncestry(curId:))modifyCfg(overscId(constNothing))unless(B.nullrte)$modifyCfg(overscRouteContext(rte:))-------------------------------------------------------------------------------- | Runs another snaplet's initializer and returns the initialized Snaplet-- value. Calling an initializer with nestSnaplet gives the nested snaplet-- access to the same base state that the current snaplet has. This makes it-- possible for the child snaplet to make use of functionality provided by-- sibling snaplets.nestSnaplet::ByteString-- ^ The root url for all the snaplet's routes. An empty-- string gives the routes the same root as the parent-- snaplet's routes.->SnapletLensvv1-- ^ Lens identifying the snaplet->SnapletInitbv1-- ^ The initializer function for the subsnaplet.->Initializerbv(Snapletv1)nestSnapletrtel(SnapletInitsnaplet)=withl$bracketInit$dosetupSnapletCallrtesnaplet-------------------------------------------------------------------------------- | Runs another snaplet's initializer and returns the initialized Snaplet-- value. The difference between this and nestSnaplet is the first type-- parameter in the third argument. The \"v1 v1\" makes the child snaplet-- think that it is top-level, which means that it will not be able to use-- functionality provided by snaplets included above it in the snaplet tree.-- This strongly isolates the child snaplet, and allows you to eliminate the b-- type variable. The embedded snaplet can still get functionality from other-- snaplets, but only if it nests or embeds the snaplet itself.embedSnaplet::ByteString-- ^ The root url for all the snaplet's routes. An empty-- string gives the routes the same root as the parent-- snaplet's routes.---- NOTE: Because of the stronger isolation provided by-- embedSnaplet, you should be more careful about using an-- empty string here.->SnapletLensvv1-- ^ Lens identifying the snaplet->SnapletInitv1v1-- ^ The initializer function for the subsnaplet.->Initializerbv(Snapletv1)embedSnapletrtel(SnapletInitsnaplet)=bracketInit$docurLens<-getLenssetupSnapletCall""chrootrte(cloneLenscurLens.subSnapletl)snaplet-------------------------------------------------------------------------------- | Changes the base state of an initializer.chroot::ByteString->SnapletLens(Snapletb)v1->Initializerv1v1a->Initializerbvachrootrtel(Initializerm)=docurState<-iGetletnewSetterf=masterReloadercurState(over(cloneLensl)f)((a,s),(Hookhook))<-liftIO$runWriterT$LT.runLensTmid$curState{_handlers=[],_hFilter=id,masterReloader=newSetter}lethandler=chrootHandlerl$_hFilters$route$_handlerssiModify$overhandlers(++[(rte,handler)]).setcleanup(_cleanups)addPostInitHookBase$upHook'lhookreturna-------------------------------------------------------------------------------- | Changes the base state of a handler.chrootHandler::SnapletLens(Snapletv)b'->Handlerb'b'a->HandlerbvachrootHandlerl(Handlerh)=Handler$dos<-get(a,s')<-liftSnap$L.runLensedhid(s^#l)modify$storingls'returna-------------------------------------------------------------------------------- | Sets a snaplet's name. All snaplets have a default name set by the-- snaplet author. This function allows you to override that name. You will-- have to do this if you have more than one instance of the same kind of-- snaplet because snaplet names must be unique. This function must-- immediately surround the snaplet's initializer. For example:---- @fooState <- nestSnaplet \"fooA\" $ nameSnaplet \"myFoo\" $ fooInit@nameSnaplet::Text-- ^ The snaplet name->SnapletInitbv-- ^ The snaplet initializer function->SnapletInitbvnameSnapletnm(SnapletInitm)=SnapletInit$modifyCfg(setscId(Justnm))>>m-------------------------------------------------------------------------------- | Adds routing to the current 'Handler'. The new routes are merged with-- the main routing section and take precedence over existing routing that was-- previously defined.addRoutes::[(ByteString,Handlerbv())]->Initializerbv()addRoutesrs=dol<-getLensctx<-iGets(_scRouteContext._curConfig)letmodRoute(r,h)=(buildPath(r:ctx),setPatternr>>withTop'lh)letrs'=mapmodRoutersiModify(\v->overhandlers(++rs')v)wheresetPatternr=dop<-getRoutePatternwhen(isNothingp)$setRoutePatternr-------------------------------------------------------------------------------- | Wraps the /base/ snaplet's routing in another handler, allowing you to run-- code before and after all routes in an application.---- Here are some examples of things you might do:---- > wrapSite (\site -> logHandlerStart >> site >> logHandlerFinished)-- > wrapSite (\site -> ensureAdminUser >> site)--wrapSite::(Handlerbv()->Handlerbv())-- ^ Handler modifier function->Initializerbv()wrapSitef0=dof<-mungeFilterf0iModify(\v->overhFilter(f.)v)------------------------------------------------------------------------------mungeFilter::(Handlerbv()->Handlerbv())->Initializerbv(Handlerbb()->Handlerbb())mungeFilterf=domyLens<-Initializeraskreturn$\m->with'myLens$f'mwheref'(Handlerm)=f$Handler$L.withTopidm-------------------------------------------------------------------------------- | Attaches an unload handler to the snaplet. The unload handler will be-- called when the server shuts down, or is reloaded.onUnload::IO()->Initializerbv()onUnloadm=docleanupRef<-iGets_cleanupliftIO$atomicModifyIORefcleanupReffwherefcurCleanup=(curCleanup>>m,())-------------------------------------------------------------------------------- |logInitMsg::IORefText->Text->IO()logInitMsgrefmsg=atomicModifyIORefref(\cur->(cur`T.append`msg,()))-------------------------------------------------------------------------------- | Initializers should use this function for all informational or error-- messages to be displayed to the user. On application startup they will be-- sent to the console. When executed from the reloader, they will be sent-- back to the user in the HTTP response.printInfo::Text->Initializerbv()printInfomsg=dologRef<-iGets_initMessagesliftIO$logInitMsglogRef(msg`T.append`"\n")-------------------------------------------------------------------------------- | Builds an IO reload action for storage in the SnapletState.mkReloader::FilePath->String->((Snapletb->Snapletb)->IO())->IORef(IO())->Initializerbb(Snapletb)->IO(EitherTextText)mkReloadercwdenvresettercleanupRefi=dojoin$readIORefcleanupRef!res<-runInitializer'resetterenvicwdeither(return.Left)goodreswheregood(b,is)=do_<-resetter(constb)msgs<-readIORef$_initMessagesisreturn$Rightmsgs-------------------------------------------------------------------------------- | Runs a top-level snaplet in the Snap monad.runBase::Handlerbba->MVar(Snapletb)->SnaparunBase(Handlerm)mvar=do!b<-liftIO(readMVarmvar)(!a,_)<-L.runLensedmidbreturn$!a-------------------------------------------------------------------------------- | Lets you change a snaplet's initial state. It's alomst like a reload,-- except that it doesn't run the initializer. It just modifies the result of-- the initializer. This can be used to let you define actions for reloading-- individual snaplets.modifyMaster::v->Handlerbv()modifyMasterv=domodifier<-getsSnapletState_snapletModifierliftIO$modifierv-------------------------------------------------------------------------------- | Internal function for running Initializers. If any exceptions were-- thrown by the initializer, this function catches them, runs any cleanup-- actions that had been registered, and returns an expanded error message-- containing the exception details as well as all messages generated by the-- initializer before the exception was thrown.runInitializer::((Snapletb->Snapletb)->IO())->String->Initializerbb(Snapletb)->IO(EitherText(Snapletb,InitializerStateb))runInitializerresetterenvb=getCurrentDirectory>>=runInitializer'resetterenvb------------------------------------------------------------------------------runInitializer'::((Snapletb->Snapletb)->IO())->String->Initializerbb(Snapletb)->FilePath->IO(EitherText(Snapletb,InitializerStateb))runInitializer'resetterenvb@(Initializeri)cwd=docleanupRef<-newIORef(return())letreloader_=mkReloadercwdenvresettercleanupRefbletbuiltinHandlers=[("/admin/reload",reloadSite)]letcfg=SnapletConfig[]cwdNothing""empty[]Nothingreloader_logRef<-newIORef""letbody=runEitherT$do((res,s),(Hookhook))<-lift$runWriterT$LT.runLensTiid$InitializerStateTruecleanupRefbuiltinHandlersidcfglogRefenvresetterres'<-hookresright(res',s)handlere=dojoin$readIORefcleanupReflogMessages<-readIOReflogRefreturn$Left$T.unlines["Initializer threw an exception...",T.pack$show(e::SomeException),"","...but before it died it generated the following output:",logMessages]catchbodyhandler-------------------------------------------------------------------------------- | Given an environment and a Snaplet initializer, produce a concatenated log-- of all messages generated during initialization, a snap handler, and a-- cleanup action. The environment is an arbitrary string such as \"devel\" or-- \"production\". This string is used to determine the name of the-- configuration files used by each snaplet. If an environment of Nothing is-- used, then runSnaplet defaults to \"devel\".runSnaplet::MaybeString->SnapletInitbb->IO(Text,Snap(),IO())runSnapletenv(SnapletInitb)=dosnapletMVar<-newEmptyMVarletresetterf=modifyMVar_snapletMVar(return.f)eRes<-runInitializerresetter(fromMaybe"devel"env)bletgo(siteSnaplet,is)=doputMVarsnapletMVarsiteSnapletmsgs<-liftIO$readIORef$_initMessagesislethandler=runBase(_hFilteris$route$_handlersis)snapletMVarcleanupAction<-readIORef$_cleanupisreturn(msgs,handler,cleanupAction)either(error.('\n':).T.unpack)goeRes-------------------------------------------------------------------------------- | Given a configuration and a snap handler, complete it and produce the-- completed configuration as well as a new toplevel handler with things like-- compression and a 500 handler set up.combineConfig::ConfigSnapa->Snap()->IO(ConfigSnapa,Snap())combineConfigconfighandler=doconf<-completeConfigconfigletcatch500=(flipcatch$fromJust$getErrorHandlerconf)letcompress=iffromJust(getCompressionconf)thenwithCompressionelseidletsite=compress$catch500handlerreturn(conf,site)-------------------------------------------------------------------------------- | Initialize and run a Snaplet. This function parses command-line arguments,-- runs the given Snaplet initializer, and starts an HTTP server running the-- Snaplet's toplevel 'Handler'.serveSnaplet::ConfigSnapAppConfig-- ^ The configuration of the server - you can usually pass a-- default 'Config' via-- 'Snap.Http.Server.Config.defaultConfig'.->SnapletInitbb-- ^ The snaplet initializer function.->IO()serveSnapletstartConfiginitializer=doconfig<-commandLineAppConfigstartConfigletenv=appEnvironment=<<getOtherconfig(msgs,handler,doCleanup)<-runSnapletenvinitializer(conf,site)<-combineConfigconfighandlercreateDirectoryIfMissingFalse"log"letserve=simpleHttpServeconfwhen(loggingEnabledconf)$liftIO$hPutStrLnstderr$T.unpackmsgs_<-try$serve$site::IO(EitherSomeException())doCleanupwhereloggingEnabled=not.(==JustFalse).getVerbose-------------------------------------------------------------------------------- | Allows you to get all of your app's config data in the IO monad without-- the web server infrastructure.loadAppConfig::FileName-- ^ The name of the config file to look for. In snap-- applications, this is something based on the-- environment...i.e. @devel.cfg@.->FilePath-- ^ Path to the root directory of your project.->IOC.ConfigloadAppConfigcfgroot=dotree<-buildLrootletgroups=loadAppConfig'cfg""$dirTreetreeloadGroupsgroups-------------------------------------------------------------------------------- | Recursive worker for loadAppConfig.loadAppConfig'::FileName->Text->DirTreea->[(Text,Wortha)]loadAppConfig'cfg_prefixd@(Dir_c)=(map((_prefix,).Required)$getCfgcfgd)++concatMap(\a->loadAppConfig'cfg(nextPrefix$namea)a)snapletswherenextPrefixp=T.concat[_prefix,T.packp,"."]snapletsDirs=filterisSnapletsDircsnaplets=concatMap(filterisDir.contents)snapletsDirsloadAppConfig'___=[]isSnapletsDir::DirTreet->BoolisSnapletsDir(Dir"snaplets"_)=TrueisSnapletsDir_=FalseisDir::DirTreet->BoolisDir(Dir__)=TrueisDir_=FalseisCfg::FileName->DirTreet->BoolisCfgcfg(Filen_)=cfg==nisCfg__=FalsegetCfg::FileName->DirTreeb->[b]getCfgcfg(Dir_c)=mapfile$filter(isCfgcfg)cgetCfg__=[]