Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 159 lines (135 sloc) 5.447 kb
10fc5b3 Christopher Olah We stick an ImplicitCAD REST Snap server in here.
authored
1 {-# LANGUAGE OverloadedStrings, ViewPatterns #-}
2
368fbae Christopher Olah Output works properly with server now.
authored
3 -- PACKAGES: snap, silently
4
10fc5b3 Christopher Olah We stick an ImplicitCAD REST Snap server in here.
authored
5 {- This is a Snap server providing a ImplicitCAD REST API.
6 It does not install by default. Its dependencies are not in the cabal file.
7 We're just sticking it in the repo for lack of a better place... -}
8
9 module Main where
10
11 import Control.Applicative
12 import Snap.Core
13 import Snap.Http.Server
14 import Snap.Util.GZip (withCompression)
15
c2d245e Christopher Olah Upates to server needed for implicitcad.org.
authored
16 import Graphics.Implicit (runOpenscad, extrudeR)
c5537fc Christopher Olah Replaced interperter/parser, now have AST step.
authored
17 import Graphics.Implicit.ExtOpenScad.Definitions (OVal (ONum))
10fc5b3 Christopher Olah We stick an ImplicitCAD REST Snap server in here.
authored
18 import Graphics.Implicit.ObjectUtil (getBox2, getBox3)
c2d245e Christopher Olah Upates to server needed for implicitcad.org.
authored
19 import Graphics.Implicit.Export.TriangleMeshFormats (jsTHREE, stl)
20 import Graphics.Implicit.Export.PolylineFormats (svg, hacklabLaserGCode)
10fc5b3 Christopher Olah We stick an ImplicitCAD REST Snap server in here.
authored
21 import Graphics.Implicit.Definitions (xmlErrorOn, errorMessage)
22 import Data.Map as Map
23 import Text.ParserCombinators.Parsec (errorPos, sourceLine)
24 import Text.ParserCombinators.Parsec.Error
25
26 -- class DiscreteApproxable
27 import Graphics.Implicit.Export.Definitions
28
29 -- instances of DiscreteApproxable...
30 import Graphics.Implicit.Export.SymbolicObj2
31 import Graphics.Implicit.Export.SymbolicObj3
32
33 import System.IO.Unsafe (unsafePerformIO)
368fbae Christopher Olah Output works properly with server now.
authored
34 import System.IO.Silently (capture)
10fc5b3 Christopher Olah We stick an ImplicitCAD REST Snap server in here.
authored
35
36 import qualified Data.ByteString.Char8 as BS.Char
b095f7f Christopher Olah Update server to use new formatters and error on too high res.
authored
37 import qualified Data.Text.Lazy as TL
10fc5b3 Christopher Olah We stick an ImplicitCAD REST Snap server in here.
authored
38
39 main :: IO ()
40 main = quickHttpServe site
41
42 site :: Snap ()
43 site = route
44 [
45 ("render/", renderHandler)
46 ] <|> writeBS "fall through"
47
48 renderHandler :: Snap ()
a124bd3 Christopher Olah Work on the implicitsnap server.
authored
49 renderHandler = method GET $ withCompression $ do
41f1a76 Christopher Olah implicitsnap now uses GZip.
authored
50 modifyResponse $ setContentType "application/x-javascript"
10fc5b3 Christopher Olah We stick an ImplicitCAD REST Snap server in here.
authored
51 request <- getRequest
c2d245e Christopher Olah Upates to server needed for implicitcad.org.
authored
52 case (rqParam "source" request, rqParam "callback" request, rqParam "format" request) of
53 (Just [source], Just [callback], Nothing) -> do
a124bd3 Christopher Olah Work on the implicitsnap server.
authored
54 writeBS $ BS.Char.pack $ executeAndExport
55 (BS.Char.unpack source)
56 (BS.Char.unpack callback)
c2d245e Christopher Olah Upates to server needed for implicitcad.org.
authored
57 Nothing
58 (Just [source], Just [callback], Just [format]) -> do
59 writeBS $ BS.Char.pack $ executeAndExport
60 (BS.Char.unpack source)
61 (BS.Char.unpack callback)
62 (Just $ BS.Char.unpack format)
63 (_, _, _) -> writeBS "must provide source and callback as 1 GET variable each"
10fc5b3 Christopher Olah We stick an ImplicitCAD REST Snap server in here.
authored
64
65
66
b095f7f Christopher Olah Update server to use new formatters and error on too high res.
authored
67 getRes (varlookup, obj2s, obj3s) =
68 let
7a856d3 Christopher Olah Add a $quality variable for scale independent render quality.
authored
69 qual = case Map.lookup "$quality" varlookup of
70 Just (ONum n) | n >= 1 -> n
71 _ -> 1
72 (defaultRes, qualRes) = case (obj2s, obj3s) of
73 (_, obj:_) -> ( min (minimum [x,y,z]/2) ((x*y*z )**(1/3) / 22)
74 , min (minimum [x,y,z]/2) ((x*y*z/qual)**(1/3) / 22))
b095f7f Christopher Olah Update server to use new formatters and error on too high res.
authored
75 where
76 ((x1,y1,z1),(x2,y2,z2)) = getBox3 obj
77 (x,y,z) = (x2-x1, y2-y1, z2-z1)
7a856d3 Christopher Olah Add a $quality variable for scale independent render quality.
authored
78 (obj:_, _) -> ( min (min x y/2) ((x*y )**0.5 / 30)
79 , min (min x y/2) ((x*y/qual)**0.5 / 30) )
b095f7f Christopher Olah Update server to use new formatters and error on too high res.
authored
80 where
81 ((x1,y1),(x2,y2)) = getBox2 obj
82 (x,y) = (x2-x1, y2-y1)
7a856d3 Christopher Olah Add a $quality variable for scale independent render quality.
authored
83 _ -> (1, 1)
b095f7f Christopher Olah Update server to use new formatters and error on too high res.
authored
84 in case Map.lookup "$res" varlookup of
85 Just (ONum requestedRes) ->
c2d245e Christopher Olah Upates to server needed for implicitcad.org.
authored
86 if defaultRes <= 30*requestedRes
b095f7f Christopher Olah Update server to use new formatters and error on too high res.
authored
87 then requestedRes
88 else -1
7a856d3 Christopher Olah Add a $quality variable for scale independent render quality.
authored
89 _ ->
c2d245e Christopher Olah Upates to server needed for implicitcad.org.
authored
90 if qual <= 30
7a856d3 Christopher Olah Add a $quality variable for scale independent render quality.
authored
91 then qualRes
92 else -1
93
10fc5b3 Christopher Olah We stick an ImplicitCAD REST Snap server in here.
authored
94
5e07b39 Christopher Olah Some server API changes.
authored
95 getWidth (varlookup, _, obj:_) = maximum [x2-x1, y2-y1, z2-z1]
96 where ((x1,y1,z1),(x2,y2,z2)) = getBox3 obj
97 getWidth (varlookup, obj:_, _) = max (x2-x1) (y2-y1)
98 where ((x1,y1),(x2,y2)) = getBox2 obj
10fc5b3 Christopher Olah We stick an ImplicitCAD REST Snap server in here.
authored
99
100
101 -- | Give an openscad object to run and the basename of
102 -- the target to write to... write an object!
c2d245e Christopher Olah Upates to server needed for implicitcad.org.
authored
103 executeAndExport :: String -> String -> Maybe String -> String
104 executeAndExport content callback maybeFormat =
a124bd3 Christopher Olah Work on the implicitsnap server.
authored
105 let
5206806 Christopher Olah Correct web API boolean representation.
authored
106 showB True = "true"
107 showB False = "false"
5e07b39 Christopher Olah Some server API changes.
authored
108 callbackF :: Bool -> Bool -> Float -> String -> String
109 callbackF False is2D w msg =
5206806 Christopher Olah Correct web API boolean representation.
authored
110 callback ++ "([null," ++ show msg ++ "," ++ showB is2D ++ "," ++ show w ++ "]);"
5e07b39 Christopher Olah Some server API changes.
authored
111 callbackF True is2D w msg =
5206806 Christopher Olah Correct web API boolean representation.
authored
112 callback ++ "([new Shape()," ++ show msg ++ "," ++ showB is2D ++ "," ++ show w ++ "]);"
5e07b39 Christopher Olah Some server API changes.
authored
113 callbackS str msg = callback ++ "([" ++ show str ++ "," ++ show msg ++ ",null,null]);"
a124bd3 Christopher Olah Work on the implicitsnap server.
authored
114 in case runOpenscad content of
115 Left err ->
116 let
117 line = sourceLine . errorPos $ err
118 showErrorMessages' = showErrorMessages
119 "or" "unknown parse error" "expecting" "unexpected" "end of input"
120 msgs :: String
121 msgs = showErrorMessages' $ errorMessages err
5e07b39 Christopher Olah Some server API changes.
authored
122 in callbackF False False 1 $ (\s-> "error (" ++ show line ++ "):" ++ s) msgs
a124bd3 Christopher Olah Work on the implicitsnap server.
authored
123 Right openscadProgram -> unsafePerformIO $ do
368fbae Christopher Olah Output works properly with server now.
authored
124 (msgs,s) <- capture $ openscadProgram
a124bd3 Christopher Olah Work on the implicitsnap server.
authored
125 let
5e07b39 Christopher Olah Some server API changes.
authored
126 res = getRes s
127 w = getWidth s
128 is2D = case s of
129 (_, _, x:xs) -> False
130 (_, x:xs, _) -> True
131 _ -> False
132 highResError = "Unreasonable resolution requested: "
133 ++ "the server imps revolt! "
134 ++ "(Install ImplicitCAD locally -- github.com/colah/ImplicitCAD/)"
c2d245e Christopher Olah Upates to server needed for implicitcad.org.
authored
135 objOrErr = case s of
136 (_, _, x:xs) ->
137 if res > 0
138 then Right (Nothing, x)
5e07b39 Christopher Olah Some server API changes.
authored
139 else Left highResError
c2d245e Christopher Olah Upates to server needed for implicitcad.org.
authored
140 (_, x:xs, _) ->
141 if res > 0
142 then Right (Just x, extrudeR 0 x res)
5e07b39 Christopher Olah Some server API changes.
authored
143 else Left highResError
c2d245e Christopher Olah Upates to server needed for implicitcad.org.
authored
144 _ -> Left $ msgs ++ "Nothing to render."
145
146 return $ case (objOrErr, maybeFormat) of
5e07b39 Christopher Olah Some server API changes.
authored
147 (Left errmsg, _) -> callbackF False False 1 errmsg
c2d245e Christopher Olah Upates to server needed for implicitcad.org.
authored
148 (Right (_,obj), Nothing) ->
5e07b39 Christopher Olah Some server API changes.
authored
149 TL.unpack (jsTHREE (discreteAprox res obj)) ++ callbackF True is2D w msgs
c2d245e Christopher Olah Upates to server needed for implicitcad.org.
authored
150 (Right (_,obj), Just "STL") ->
151 callbackS (TL.unpack (stl (discreteAprox res obj))) msgs
152 (Right (Just obj, _), Just "SVG") ->
153 callbackS (TL.unpack (svg (discreteAprox res obj))) msgs
154 (Right (Just obj, _), Just "gcode/hacklab-laser") ->
155 callbackS (TL.unpack (hacklabLaserGCode (discreteAprox res obj))) msgs
156
10fc5b3 Christopher Olah We stick an ImplicitCAD REST Snap server in here.
authored
157
158
Something went wrong with that request. Please try again.