The file you uploaded appears to have the content type <% contentType %>. However, at this time the only supported types are <% acceptedTypes %>.
+ + (Just (ext, kind)) -> + do -- renameFile would be faster, but may not work if it has to cross physical devices + -- in theory, the filename could be the md5sum of the file making it easy to check for corruption + mid@(MediumId i) <- update GenMediumId + let destPath = show i `addExtension` ext + liftIO $ copyFile tempPath (md destPath) + let medium = Medium { mediumId = mid + , uploadName = origName + , mediumPath = destPath + , mediumKind = kind + } + update (PutMedium medium) + seeOtherURL (GetMedium mid) + +uploadForm :: MediaForm (FilePath, FilePath, ContentType) +uploadForm = + label "upload file: " ++> inputFile <* inputSubmit (pack "Upload") diff --git a/Clckwrks/Media/Plugin.hs b/Clckwrks/Media/Plugin.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Media/Plugin.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE RecordWildCards, FlexibleContexts, OverloadedStrings #-} +module Clckwrks.Media.Plugin where + +import Clckwrks +import Clckwrks.IOThread (IOThread(..), startIOThread, killIOThread) +import Clckwrks.Plugin (clckPlugin) +import Clckwrks.Media.Acid (initialMediaState) +import Clckwrks.Media.Monad (MediaConfig(..), runMediaT) +import Clckwrks.Media.PreProcess (mediaCmd) +import Clckwrks.Media.Preview (applyTransforms) +import Clckwrks.Media.Route (routeMedia) +import Clckwrks.Media.URL (MediaURL(..), MediaAdminURL(..)) +import Control.Concurrent (ThreadId, killThread) +import Control.Monad.State (get) +import Data.Acid as Acid +import Data.Acid.Local (createCheckpointAndClose, openLocalStateFrom) +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import Magic (Magic, MagicFlag(..), magicLoadDefault, magicOpen) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import Web.Plugins.Core (Plugin(..), Plugins(..), When(..), addCleanup, addHandler, initPlugin, getConfig, getPluginRouteFn) + +mediaHandler :: (MediaURL -> [(Text, Maybe Text)] -> Text) + -> MediaConfig + -> ClckPlugins + -> [Text] + -> ClckT ClckURL (ServerPartT IO) Response +mediaHandler showMediaURL mediaConfig plugins paths = + case parseSegments fromPathSegments paths of + (Left e) -> notFound $ toResponse (show e) + (Right u) -> + ClckT $ withRouteT flattenURL $ unClckT $ runMediaT mediaConfig $ routeMedia u + where + flattenURL :: ((url' -> [(Text, Maybe Text)] -> Text) -> (MediaURL -> [(Text, Maybe Text)] -> Text)) + flattenURL _ u p = showMediaURL u p + +mediaInit :: ClckPlugins + -> IO (Maybe Text) +mediaInit plugins = + do (Just mediaShowFn) <- getPluginRouteFn plugins (pluginName mediaPlugin) + (Just clckShowFn) <- getPluginRouteFn plugins (pluginName clckPlugin) + mTopDir <- clckTopDir <$> getConfig plugins + let basePath = maybe "_state" (\td -> td "_state") mTopDir -- FIXME + mediaDir = maybe "_media" (\td -> td "_media") mTopDir + cacheDir = mediaDir "_cache" + createDirectoryIfMissing True cacheDir + + acid <- openLocalStateFrom (basePath "media") initialMediaState + addCleanup plugins Always (createCheckpointAndClose acid) + + ioThread <- startIOThread (applyTransforms mediaDir cacheDir) + addCleanup plugins Always (killIOThread ioThread) + + magic <- magicOpen [MagicMime, MagicError] + magicLoadDefault magic + + let mediaConfig = MediaConfig { mediaDirectory = mediaDir + , mediaState = acid + , mediaMagic = magic + , mediaIOThread = ioThread + , mediaClckURL = clckShowFn + } + + addPreProc plugins (mediaCmd mediaShowFn) + addHandler plugins (pluginName mediaPlugin) (mediaHandler mediaShowFn mediaConfig) + + return Nothing + +addMediaAdminMenu :: ClckT url IO () +addMediaAdminMenu = + do p <- plugins <$> get + (Just mediaShowURL) <- getPluginRouteFn p (pluginName mediaPlugin) + let uploadURL = mediaShowURL (MediaAdmin Upload) [] + allMediaURL = mediaShowURL (MediaAdmin AllMedia) [] + addAdminMenu ("Media Gallery", [("Upload", uploadURL) + ,("All Media", allMediaURL) + ]) + +mediaPlugin :: Plugin MediaURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig [TL.Text -> ClckT ClckURL IO TL.Text] +mediaPlugin = Plugin + { pluginName = "media" + , pluginInit = mediaInit + , pluginDepends = [] + , pluginToPathInfo = toPathInfo + , pluginPostHook = addMediaAdminMenu + } + +plugin :: ClckPlugins -- ^ plugins + -> Text -- ^ baseURI + -> IO (Maybe Text) +plugin plugins baseURI = + initPlugin plugins baseURI mediaPlugin + diff --git a/Clckwrks/Media/PreProcess.hs b/Clckwrks/Media/PreProcess.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Media/PreProcess.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} +module Clckwrks.Media.PreProcess where +import Control.Monad.Trans +import Control.Applicative +import Clckwrks (ClckT, ClckState) +import Clckwrks.Media.URL +import Clckwrks.Media.Types (MediumId(..)) +import Clckwrks.Monad (transform, segments) +import Data.Attoparsec.Text.Lazy (Parser, Result(..), char, choice, decimal, parse, skipMany, space, stringCI, skipMany) +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as B +import Text.Blaze.Html ((!), toValue) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Text.Blaze.Html.Renderer.Text (renderHtml) +import Web.Routes (showURL) + +parseAttr :: Text -> Parser () +parseAttr name = + do skipMany space + stringCI name + skipMany space + char '=' + skipMany space + +width :: Parser H.Attribute +width = + A.width . H.toValue <$> (parseAttr "width" *> (decimal :: Parser Integer)) + +height :: Parser H.Attribute +height = + A.height . H.toValue <$> (parseAttr "height" *> (decimal :: Parser Integer)) + +parseCmd :: Parser (MediumId, [H.Attribute]) +parseCmd = + (,) <$> (parseAttr "id" *> (MediumId <$> decimal)) + <*> (many $ choice [ width, height ]) + +mediaCmd :: (Monad m) => + (MediaURL -> [(Text, Maybe Text)] -> Text) + -> TL.Text + -> ClckT url m TL.Text +mediaCmd mediaShowURL txt = + case parse (segments "media" parseCmd) txt of + (Fail _ _ e) -> return (TL.pack e) + (Done _ segments) -> + do b <- transform (applyCmd mediaShowURL) segments + return $ B.toLazyText b + +applyCmd mediaShowURL (mid, attrs) = + do let u = toValue $ mediaShowURL (GetMedium mid) [] + return $ B.fromLazyText $ renderHtml $ foldr (\attr tag -> tag ! attr) H.img (A.src u : attrs) diff --git a/Clckwrks/Media/Preview.hs b/Clckwrks/Media/Preview.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Media/Preview.hs @@ -0,0 +1,44 @@ +module Clckwrks.Media.Preview where + +import Control.Applicative ((<$>)) +import Control.Monad (unless) +import Control.Monad.Reader (ask) +import Control.Monad.Trans (liftIO) +import Clckwrks (query) +import Clckwrks.IOThread (ioRequest) +import Clckwrks.Media.Acid (GetMediumById(..)) +import Clckwrks.Media.Types (Medium(..), MediumId(..), MediumKind(..), PreviewSize(..)) + +import Graphics.GD (imageSize, loadJpegFile, resizeImage, saveJpegFile, withImage) +import qualified Graphics.GD as GD +import System.Directory (doesFileExist) +import System.FilePath ((), splitExtension) + +jpgThumbnail :: PreviewSize -> FilePath -> FilePath -> IO () +jpgThumbnail size inPath outPath = + withImage (loadJpegFile inPath) $ \image -> + do (w,h) <- imageSize image + let (w', h') = + if w > h + then (maxWidth, (h * maxWidth) `div` w) + else ((w * maxHeight) `div` h, maxHeight) + image' <- resizeImage w' h' image + saveJpegFile 60 outPath image' + where + maxWidth = case size of + Tall -> 200 + Grande -> 300 + Venti -> 400 + maxHeight = maxWidth + +mkThumbnail :: MediumKind -> PreviewSize -> FilePath -> FilePath -> IO () +mkThumbnail JPEG = jpgThumbnail + +applyTransforms :: FilePath -> FilePath -> (Medium, PreviewSize) -> IO FilePath +applyTransforms storageDir cacheDir (medium, size) = + let origFP = storageDir (mediumPath medium) + (name, ext) = splitExtension (mediumPath medium) + thumbFP = cacheDir name ++ "_" ++ (show size) ++ ext + in do e <- doesFileExist thumbFP + unless e (mkThumbnail (mediumKind medium) size origFP thumbFP) + return thumbFP diff --git a/Clckwrks/Media/Route.hs b/Clckwrks/Media/Route.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Media/Route.hs @@ -0,0 +1,33 @@ +module Clckwrks.Media.Route where + +import Control.Applicative ((<$>)) +import Control.Monad.Reader (ask) +import Clckwrks (Clck, Role(..), requiresRole_) +import Clckwrks.Media.Monad (MediaM, MediaConfig(..)) +import Clckwrks.Media.URL (MediaURL(..), MediaAdminURL(..)) +import Clckwrks.Media.Page.AllMedia (allMedia) +import Clckwrks.Media.Page.GetMedium (getMedium) +import Clckwrks.Media.Page.Preview (previewMedium) +import Clckwrks.Media.Page.Upload (uploadMedium) +import qualified Data.Set as Set +import Happstack.Server (Response) +import Magic +-- import Paths_clckwrks_plugin_media (getDataDir) + +checkAuth :: MediaURL -> MediaM MediaURL +checkAuth url = + case url of + MediaAdmin {} -> + do showFn <- mediaClckURL <$> ask + requiresRole_ showFn (Set.singleton Administrator) url + _ -> return url + + +routeMedia :: MediaURL -> MediaM Response +routeMedia unsecureURL = + do url <- checkAuth unsecureURL + case url of + (MediaAdmin Upload) -> uploadMedium url + (MediaAdmin AllMedia) -> allMedia + (GetMedium mid) -> getMedium mid + (Preview mid) -> previewMedium mid diff --git a/Clckwrks/Media/Types.hs b/Clckwrks/Media/Types.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Media/Types.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-} +module Clckwrks.Media.Types where + +import Data.Data (Data, Typeable) +import Data.IxSet (Indexable(..), ixSet, ixFun) +import Data.SafeCopy (SafeCopy, base, deriveSafeCopy) +import Data.Text (Text) +import Web.Routes (PathInfo(..)) + +newtype MediumId = MediumId { unMediumId :: Integer } + deriving (Eq, Ord, Read, Show, Data, Typeable, SafeCopy, PathInfo) + +data MediumKind + = JPEG + deriving (Eq, Ord, Read, Show, Data, Typeable) +$(deriveSafeCopy 0 'base ''MediumKind) + +mediumContentType :: MediumKind -> String +mediumContentType JPEG = "image/jpeg; charset=binary" + +data Medium + = Medium { mediumId :: MediumId + , uploadName :: FilePath + , mediumPath :: FilePath + , mediumKind :: MediumKind + -- , fileSize :: Integer + } + deriving (Eq, Ord, Read, Show, Data, Typeable) +$(deriveSafeCopy 0 'base ''Medium) + +data PreviewSize + = Tall + | Grande + | Venti + deriving (Eq, Ord, Read, Show, Data, Typeable) +$(deriveSafeCopy 0 'base ''PreviewSize) + +instance Indexable Medium where + empty = ixSet [ ixFun ((:[]) . mediumId) + ] diff --git a/Clckwrks/Media/URL.hs b/Clckwrks/Media/URL.hs new file mode 100644 --- /dev/null +++ b/Clckwrks/Media/URL.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-} +module Clckwrks.Media.URL where + +import Clckwrks.Media.Types (MediumId(..)) +import Data.Data (Data, Typeable) +import Web.Routes.TH (derivePathInfo) + +data MediaAdminURL + = Upload + | AllMedia + deriving (Eq, Ord, Read, Show, Data, Typeable) +$(derivePathInfo ''MediaAdminURL) + +data MediaURL + = GetMedium MediumId + | Preview MediumId + | MediaAdmin MediaAdminURL + deriving (Eq, Ord, Read, Show, Data, Typeable) +$(derivePathInfo ''MediaURL) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Jeremy Shaw, SeeReason Partners LLC + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jeremy Shaw nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,13 @@ +#!/usr/bin/env runghc + +module Main where + +import Distribution.Simple +import Distribution.Simple.Program + +trhsxProgram = simpleProgram "trhsx" + +main :: IO () +main = defaultMainWithHooks simpleUserHooks { + hookedPrograms = [trhsxProgram] + } diff --git a/clckwrks-plugin-media.cabal b/clckwrks-plugin-media.cabal new file mode 100644 --- /dev/null +++ b/clckwrks-plugin-media.cabal @@ -0,0 +1,64 @@ +Name: clckwrks-plugin-media +Version: 0.3.0 +Synopsis: media plugin for clckwrks +Homepage: http://clckwrks.com/ +License: BSD3 +License-file: LICENSE +Author: Jeremy Shaw +Maintainer: Jeremy Shaw