{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE ScopedTypeVariables #-}{-# LANGUAGE NoImplicitPrelude #-}{-# LANGUAGE TemplateHaskell #-}{-# LANGUAGE RecordWildCards #-}moduleKeter.App(App,start,reload,Keter.App.terminate)whereimportPrelude(IO,Eq,Ord,fst,snd)importKeter.PreludeimportKeter.TempFolderimportKeter.PostgresimportKeter.ProcessimportKeter.ProcessTracker(ProcessTracker)importKeter.Logger(Logger,detach)importKeter.PortManagerhiding(start)importqualifiedCodec.Archive.TarasTarimportqualifiedCodec.Archive.Tar.CheckasTarimportqualifiedCodec.Archive.Tar.EntryasTarimportCodec.Compression.GZip(decompress)importqualifiedFilesystem.Path.CurrentOSasFimportqualifiedFilesystemasFimportData.YamlimportControl.Applicative((<$>),(<*>),(<|>),pure)importqualifiedNetworkimportData.Maybe(fromMaybe,mapMaybe)importControl.Exception(onException,throwIO,bracket)importSystem.IO(hClose)importqualifiedData.ByteString.LazyasLimportData.Conduit(($$),yield)importData.Set(Set)importqualifiedData.SetasSetimportqualifiedData.Conduit.ListasCLimportSystem.Posix.IO.ByteString(fdWriteBuf,closeFd,FdOption(CloseOnExec),setFdOption,createFile)importForeign.Ptr(castPtr)importData.ByteString.Unsafe(unsafeUseAsCStringLen)importData.Text.Encoding(encodeUtf8)importSystem.Posix.Types(UserID,GroupID)importSystem.Posix.Files.ByteString(setOwnerAndGroup,setFdOwnerAndGroup)importControl.Monad(unless)dataAppConfig=AppConfig{configExec::F.FilePath,configArgs::[Text],configHost::Text,configPostgres::Bool,configSsl::Bool,configExtraHosts::SetString}instanceFromJSONAppConfigwhereparseJSON(Objecto)=AppConfig<$>(F.fromText<$>o.:"exec")<*>o.:?"args".!=[]<*>o.:"host"<*>o.:?"postgres".!=False<*>o.:?"ssl".!=False<*>o.:?"extra-hosts".!=Set.emptyparseJSON_=fail"Wanted an object"dataConfig=Config{configApp::MaybeAppConfig,configStaticHosts::SetStaticHost,configRedirects::SetRedirect}instanceFromJSONConfigwhereparseJSON(Objecto)=Config<$>((Just<$>parseJSON(Objecto))<|>pureNothing)<*>o.:?"static-hosts".!=Set.empty<*>o.:?"redirects".!=Set.emptyparseJSON_=fail"Wanted an object"dataStaticHost=StaticHost{shHost::String,shRoot::FilePath}deriving(Eq,Ord)instanceFromJSONStaticHostwhereparseJSON(Objecto)=StaticHost<$>o.:"host"<*>(F.fromText<$>o.:"root")parseJSON_=fail"Wanted an object"dataRedirect=Redirect{redFrom::Text,redTo::Text}deriving(Eq,Ord)instanceFromJSONRedirectwhereparseJSON(Objecto)=Redirect<$>o.:"from"<*>o.:"to"parseJSON_=fail"Wanted an object"dataCommand=Reload|TerminatenewtypeApp=App(Command->KIO())unpackBundle::TempFolder->Maybe(UserID,GroupID)->F.FilePath->Appname->KIO(EitherSomeException(FilePath,Config))unpackBundletfmuidbundleappname=doelbs<-readFileLBSbundlecaseelbsofLefte->return$LefteRightlbs->doedir<-getFoldermuidtfappnamecaseedirofLefte->return$LefteRightdir->dolog$UnpackingBundlebundledirletrest=dounpackTarmuiddir$Tar.read$decompresslbsletconfigFP=dirF.</>"config"F.</>"keter.yaml"mconfig<-decodeFile$F.encodeStringconfigFPconfig<-casemconfigofJustconfig->returnconfigNothing->throwIOInvalidConfigFilereturn(dir,config{configStaticHosts=Set.fromList$mapMaybe(fixStaticHostdir)$Set.toList$configStaticHostsconfig})liftIO$rest`onException`removeTreedir-- | Ensures that the given path does not escape the containing folder and sets-- the pathname based on config file location.fixStaticHost::FilePath->StaticHost->MaybeStaticHostfixStaticHostdirsh=case(F.stripPrefix(F.collapsedirF.</>"")fp,F.relativefp0)of(Just_,True)->Justsh{shRoot=fp}_->Nothingwherefp0=shRootshfp=F.collapse$dirF.</>"config"F.</>fp0-- | Create a directory tree, setting the uid and gid of all newly created-- folders.createTreeUID::UserID->GroupID->FilePath->IO()createTreeUIDuidgid=gowheregofp=doexists<-F.isDirectoryfpunlessexists$dogo$F.parentfpF.createDirectoryFalsefpsetOwnerAndGroup(F.encodefp)uidgidunpackTar::Maybe(UserID,GroupID)->FilePath->Tar.EntriesTar.FormatError->IO()unpackTarmuiddir=loop.Tar.checkSecuritywhereloopTar.Done=return()loop(Tar.Faile)=eitherthrowIOthrowIOeloop(Tar.Nextees)=goe>>loopesgoe=doletfp=dir</>decodeString(Tar.entryPathe)caseTar.entryContenteofTar.NormalFilelbs_->docasemuidofNothing->createTree$F.directoryfpJust(uid,gid)->createTreeUIDuidgid$F.directoryfpletwritefdbs=unsafeUseAsCStringLenbs$\(ptr,len)->do_<-fdWriteBuffd(castPtrptr)(fromIntegrallen)return()bracket(dofd<-createFile(F.encodefp)$Tar.entryPermissionsesetFdOptionfdCloseOnExecTruecasemuidofNothing->return()Just(uid,gid)->setFdOwnerAndGroupfduidgidreturnfd)closeFd(\fd->mapM_yield(L.toChunkslbs)$$CL.mapM_(writefd))_->return()start::TempFolder->Maybe(Text,(UserID,GroupID))->ProcessTracker->PortManager->Postgres->Logger->Appname->F.FilePath-- ^ app bundle->KIO()-- ^ action to perform to remove this App from list of actives->KIO(App,KIO())starttfmuidprocessTrackerportmanpostgresloggerappnamebundleremoveFromList=dochan<-newChanreturn(App$writeChanchan,restchan)whererunAppportdirconfig=dootherEnv<-domdbi<-ifconfigPostgresconfigthendoedbi<-getInfopostgresappnamecaseedbiofLefte->do$logExereturnNothingRightdbi->return$JustdbielsereturnNothingreturn$casemdbiofJustdbi->[("PGHOST","localhost"),("PGPORT","5432"),("PGUSER",dbiUserdbi),("PGPASS",dbiPassdbi),("PGDATABASE",dbiNamedbi)]Nothing->[]letenv=("PORT",showport):("APPROOT",(ifconfigSslconfigthen"https://"else"http://")++configHostconfig):otherEnvrunprocessTracker(fst<$>muid)("config"</>configExecconfig)dir(configArgsconfig)envloggerrestchan=forkKIO$domres<-unpackBundletf(snd<$>muid)bundleappnamecasemresofLefte->do$logExeremoveFromListRight(dir,config)->doletcommon=domapM_(\StaticHost{..}->addEntryportmanshHost(PEStaticshRoot))$Set.toList$configStaticHostsconfigmapM_(\Redirect{..}->addEntryportmanredFrom(PERedirect$encodeUtf8redTo))$Set.toList$configRedirectsconfigcaseconfigAppconfigofNothing->docommonloopchandirconfigNothingJustappconfig->doeport<-getPortportmancaseeportofLefte->do$logExeremoveFromListRightport->doprocess<-runAppportdirappconfigb<-testAppportifbthendoaddEntryportman(configHostappconfig)$PEPortportmapM_(flip(addEntryportman)$PEPortport)$Set.toList$configExtraHostsappconfigcommonloopchandirconfig$Just(process,port)elsedoremoveFromListreleasePortportmanportKeter.Process.terminateprocessloopchandirOldconfigOldmprocPortOld=docommand<-readChanchancasecommandofTerminate->doremoveFromListcaseconfigAppconfigOldofNothing->return()Justappconfig->doremoveEntryportman$configHostappconfigmapM_(removeEntryportman)$Set.toList$configExtraHostsappconfigmapM_(removeEntryportman)$mapshHost$Set.toList$configStaticHostsconfigOldmapM_(removeEntryportman)$mapredFrom$Set.toList$configRedirectsconfigOldlog$TerminatingAppappnameterminateOlddetachloggerReload->domres<-unpackBundletf(snd<$>muid)bundleappnamecasemresofLefte->dolog$InvalidBundlebundleeloopchandirOldconfigOldmprocPortOldRight(dir,config)->doeport<-getPortportmancaseeportofLefte->$logExeRightport->doletcommon=domapM_(\StaticHost{..}->addEntryportmanshHost(PEStaticshRoot))$Set.toList$configStaticHostsconfigmapM_(\Redirect{..}->addEntryportmanredFrom(PERedirect$encodeUtf8redTo))$Set.toList$configRedirectsconfigcaseconfigAppconfigofNothing->docommonloopchandirconfigNothingJustappconfig->doprocess<-runAppportdirappconfigb<-testAppportifbthendoaddEntryportman(configHostappconfig)$PEPortportmapM_(flip(addEntryportman)$PEPortport)$Set.toList$configExtraHostsappconfigcommoncaseconfigAppconfigOldofJustappconfigOld|configHostappconfig/=configHostappconfigOld->removeEntryportman$configHostappconfigOld_->return()log$FinishedReloadingappnameterminateOldloopchandirconfig$Just(process,port)elsedoreleasePortportmanportKeter.Process.terminateprocesslog$ProcessDidNotStartbundleloopchandirOldconfigOldmprocPortOldwhereterminateOld=forkKIO$dothreadDelay$20*1000*1000log$TerminatingOldProcessappnamecasemprocPortOldofNothing->return()Just(processOld,_)->Keter.Process.terminateprocessOldthreadDelay$60*1000*1000log$RemovingOldFolderdirOldres<-liftIO$removeTreedirOldcaseresofLefte->$logExeRight()->return()testApp::Port->KIOBooltestAppport=dores<-timeout(90*1000*1000)testApp'return$fromMaybeFalsereswheretestApp'=dothreadDelay$2*1000*1000eres<-liftIO$Network.connectTo"127.0.0.1"$Network.PortNumber$fromIntegralportcaseeresofLeft_->testApp'Righthandle->dores<-liftIO$hClosehandlecaseresofLefte->$logExeRight()->return()returnTruereload::App->KIO()reload(Appf)=fReloadterminate::App->KIO()terminate(Appf)=fTerminate